Theory Smith_Normal_Form

(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section ‹Definition of Smith normal form in HOL Analysis›

theory Smith_Normal_Form
  imports   
    Hermite.Hermite   
begin


subsection ‹Definitions›

text‹Definition of diagonal matrix›

definition "isDiagonal_upt_k A k = ( a b. (to_nat a  to_nat b  (to_nat a < k  (to_nat b < k)))  A $ a $ b = 0)"
definition "isDiagonal A = ( a b. to_nat a  to_nat b  A $ a $ b = 0)"

lemma isDiagonal_intro:
  fixes A::"'a::{zero}^'cols::mod_type^'rows::mod_type"
  assumes "a::'rows. b::'cols. to_nat a = to_nat b"
  shows "isDiagonal A"
  using assms
  unfolding isDiagonal_def by auto

text‹Definition of Smith normal form up to position k. The element $A_{k-1,k-1}$ 
does not need to divide $A_{k,k}$ and $A_{k,k}$ could have non-zero entries above and below.›

  definition "Smith_normal_form_upt_k A k = 
  (
    (a b. to_nat a = to_nat b  to_nat a + 1 < k  to_nat b + 1< k  A $ a $ b dvd A $ (a+1) $ (b+1))
     isDiagonal_upt_k A k
  )"

definition "Smith_normal_form A = 
  (
    (a b. to_nat a = to_nat b  to_nat a + 1 < nrows A  to_nat b + 1 < ncols A  A $ a $ b dvd A $ (a+1) $ (b+1))
     isDiagonal A    
  )"

subsection ‹Basic properties›

lemma Smith_normal_form_min: 
  "Smith_normal_form A = Smith_normal_form_upt_k A (min (nrows A) (ncols A))"
  unfolding Smith_normal_form_def Smith_normal_form_upt_k_def nrows_def ncols_def 
  unfolding isDiagonal_upt_k_def isDiagonal_def
  by (auto, smt Suc_le_eq le_trans less_le min.boundedI not_less_eq_eq suc_not_zero 
      to_nat_less_card to_nat_plus_one_less_card')


lemma Smith_normal_form_upt_k_0[simp]: "Smith_normal_form_upt_k A 0" 
  unfolding Smith_normal_form_upt_k_def 
  unfolding isDiagonal_upt_k_def isDiagonal_def
  by auto

lemma Smith_normal_form_upt_k_intro:
  assumes "(a b. to_nat a = to_nat b  to_nat a + 1 < k  to_nat b + 1< k  A $ a $ b dvd A $ (a+1) $ (b+1))"
  and "(a b. (to_nat a  to_nat b  (to_nat a < k  (to_nat b < k)))  A $ a $ b = 0)"
shows "Smith_normal_form_upt_k A k"
  unfolding Smith_normal_form_upt_k_def 
  unfolding isDiagonal_upt_k_def isDiagonal_def using assms by simp

lemma Smith_normal_form_upt_k_intro_alt:
  assumes "(a b. to_nat a = to_nat b  to_nat a + 1 < k  to_nat b + 1 < k  A $ a $ b dvd A $ (a+1) $ (b+1))"
  and "isDiagonal_upt_k A k"
  shows "Smith_normal_form_upt_k A k"
  using assms 
  unfolding Smith_normal_form_upt_k_def by auto 

lemma Smith_normal_form_upt_k_condition1:
  fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
  assumes "Smith_normal_form_upt_k A k" 
  and "to_nat a = to_nat b" and " to_nat a + 1 < k" and "to_nat b + 1 < k "
  shows "A $ a $ b dvd A $ (a+1) $ (b+1)"          
  using assms unfolding Smith_normal_form_upt_k_def by auto


lemma Smith_normal_form_upt_k_condition2:
  fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
  assumes "Smith_normal_form_upt_k A k" 
  and "to_nat a  to_nat b" and "(to_nat a < k  to_nat b < k)"
  shows "((A $ a) $ b) = 0"
  using assms unfolding Smith_normal_form_upt_k_def
  unfolding isDiagonal_upt_k_def isDiagonal_def by auto


lemma Smith_normal_form_upt_k1_intro:
  fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
  assumes s: "Smith_normal_form_upt_k A k" 
  and cond1: "A $ from_nat (k - 1) $ from_nat (k-1) dvd A $ (from_nat k) $ (from_nat k)"
  and cond2a: "a. to_nat a > k  A $ a $ from_nat k = 0"
  and cond2b: "b. to_nat b > k  A $ from_nat k $ b = 0"
shows "Smith_normal_form_upt_k A (Suc k)"
proof (rule Smith_normal_form_upt_k_intro)
  fix a::'rows and b::'cols 
  assume a: "to_nat a  to_nat b  (to_nat a < Suc k  to_nat b < Suc k)"
  show "A $ a $ b = 0" 
    by (metis Smith_normal_form_upt_k_condition2 a 
        assms(1) cond2a cond2b from_nat_to_nat_id less_SucE nat_neq_iff)
next
  fix a::'rows and b::'cols 
  assume a: "to_nat a = to_nat b  to_nat a + 1 < Suc k  to_nat b + 1 < Suc k"
  show "A $ a $ b dvd A $ (a + 1) $ (b + 1)"
    by (metis (mono_tags, lifting) Smith_normal_form_upt_k_condition1 a add_diff_cancel_right' cond1
        from_nat_suc from_nat_to_nat_id less_SucE s)
qed

lemma Smith_normal_form_upt_k1_intro_diagonal:
  fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
  assumes s: "Smith_normal_form_upt_k A k" 
  and d: "isDiagonal A"
  and cond1: "A $ from_nat (k - 1) $ from_nat (k-1) dvd A $ (from_nat k) $ (from_nat k)"
shows "Smith_normal_form_upt_k A (Suc k)"
proof (rule Smith_normal_form_upt_k_intro)
  fix a::'rows and b::'cols 
  assume a: "to_nat a = to_nat b  to_nat a + 1 < Suc k  to_nat b + 1 < Suc k"
  show "A $ a $ b dvd A $ (a + 1) $ (b + 1)"
    by (metis (mono_tags, lifting) Smith_normal_form_upt_k_condition1 a 
        add_diff_cancel_right' cond1 from_nat_suc from_nat_to_nat_id less_SucE s)    
next
  show "a b. to_nat a  to_nat b  (to_nat a < Suc k  to_nat b < Suc k)  A $ a $ b = 0"
    using d isDiagonal_def by blast
qed


end

Theory Diagonal_To_Smith

(*
    Author:      Jose Divasón
    Email:       jose.divason@unirioja.es           
*)

section ‹Algorithm to transform a diagonal matrix into its Smith normal form›

theory Diagonal_To_Smith
  imports Hermite.Hermite
  "HOL-Types_To_Sets.Types_To_Sets"
  Smith_Normal_Form
begin


(*Move this theorem:*)
lemma invertible_mat_1: "invertible (mat (1::'a::comm_ring_1))"
  unfolding invertible_iff_is_unit by simp

subsection ‹Implementation of the algorithm›

type_synonym 'a bezout = "'a  'a  'a × 'a × 'a × 'a × 'a"

hide_const Countable.from_nat
hide_const Countable.to_nat

text ‹The algorithm is based on the one presented by Bradley in his article entitled 
  ``Algorithms for Hermite and Smith normal matrices and linear diophantine equations''. 
  Some improvements have been introduced to get a general version for any matrix (including
  non-square and singular ones).›

text ‹I also introduced another improvement: the element in the position j does not need 
to be checked each time, since the element $A_{ii}$ will already divide $A_{jj}$ (where $j \le k$). 
The gcd will be placed in $A_{ii}$.›


(*This version is a valid implementation and permits the formalization, 
  but it would not be executable due to the abstraction*)

(*
primrec diagonal_to_Smith_i :: "nat list ⇒ 'a:: {gcd,divide}^'n::mod_type^'n::mod_type ⇒ 'n::mod_type ⇒ 'a^'n::mod_type^'n::mod_type" 
 where
"diagonal_to_Smith_i [] A i  = A" |
"diagonal_to_Smith_i (j#xs) A i  = (
  if A $ i $ i dvd A $ (from_nat j) $ (from_nat j) then diagonal_to_Smith_i xs A i  (*If it divides, then we proceed.*)
  else 
      let c = gcd (A$i$i) (A$(from_nat j)$(from_nat j));
          A' = (χ a b. if a = i ∧ b = i then c else 
               if a = from_nat j ∧ b = from_nat j 
               then A$ i $ i * (A $ (from_nat j) $ (from_nat j) div c) else A $ a $ b)
      in diagonal_to_Smith_i xs A' i (*We do the step and proceed*)
  )
  "
*)

text ‹This function transforms the element $A_{jj}$ in order to be divisible by $A_{ii}$
(and it changes $A_{ii}$ as well).

The use of @{text "from_nat"} and @{text "from_nat"} is mandatory since the same 
index $i$ cannot be used for both rows
and columns at the same time, since they could have different type, concretely, 
when the matrix is rectangular.›

text‹The following definition is valid, but since execution requires the trick of converting
all operations in terms of rows, then we would be recalculating the B\'ezout coefficients each time.›

(*
definition "diagonal_step A i j bezout = (let
              (p, q, u, v, d) = bezout (A $ from_nat i $ from_nat i) (A $ (from_nat j) $ (from_nat j)) in 
              (χ a b. if a = from_nat i ∧ b = from_nat i then d else 
               if a = from_nat j ∧ b = from_nat j 
               then  v * (A $ (from_nat j) $ (from_nat j)) else A $ a $ b))"
*)

text‹Thus, the definition is parameterized by the necessary elements instead of the operation, 
     to avoid recalculations.›

definition "diagonal_step A i j d v =               
              (χ a b. if a = from_nat i  b = from_nat i then d else 
               if a = from_nat j  b = from_nat j 
               then  v * (A $ (from_nat j) $ (from_nat j)) else A $ a $ b)"


fun diagonal_to_Smith_i :: 
"nat list  'a::{bezout_ring}^'cols::mod_type^'rows::mod_type  nat  ('a bezout) 
   'a^'cols::mod_type^'rows::mod_type" 
 where
"diagonal_to_Smith_i [] A i bezout = A" |
"diagonal_to_Smith_i (j#xs) A i bezout = (
  if A $ (from_nat i) $ (from_nat i) dvd A $ (from_nat j) $ (from_nat j) 
      then diagonal_to_Smith_i xs A i bezout
  else let (p, q, u, v, d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j); 
          A' = diagonal_step A i j d v
      in diagonal_to_Smith_i xs A' i bezout
  )
  "

definition "Diagonal_to_Smith_row_i A i bezout 
  = diagonal_to_Smith_i [i+1..<min (nrows A) (ncols A)] A i bezout"

fun diagonal_to_Smith_aux :: " 'a::{bezout_ring}^'cols::mod_type^'rows::mod_type 
   nat list  ('a bezout)   'a^'cols::mod_type^'rows::mod_type"
  where
  "diagonal_to_Smith_aux A [] bezout = A" |
  "diagonal_to_Smith_aux A (i#xs) bezout 
          = diagonal_to_Smith_aux (Diagonal_to_Smith_row_i A i bezout) xs bezout"

text‹The minimum arises to include the case of non-square matrices (we do not 
  demand the input diagonal matrix to be square, just have zeros in non-diagonal entries).

  This iteration does not need to be performed until the last element of the diagonal, 
  because in the second-to-last step the matrix will be already in Smith normal form.›

definition "diagonal_to_Smith A bezout 
  = diagonal_to_Smith_aux A [0..<min (nrows A) (ncols A) - 1] bezout"

subsection‹Code equations to get an executable version›

definition diagonal_step_row 
  where "diagonal_step_row A i j c v a = vec_lambda (%b. if a = from_nat i  b = from_nat i then c else 
               if a = from_nat j  b = from_nat j 
               then v * (A $ (from_nat j) $ (from_nat j)) else A $ a $ b)"

lemma diagonal_step_code [code abstract]:
  "vec_nth (diagonal_step_row A i j c v a) = (%b. if a = from_nat i  b = from_nat i then c else 
               if a = from_nat j  b = from_nat j 
               then v * (A $ (from_nat j) $ (from_nat j)) else A $ a $ b)"
  unfolding diagonal_step_row_def by auto 

lemma diagonal_step_code_nth [code abstract]: "vec_nth (diagonal_step A i j c v) 
  = diagonal_step_row A i j c v"
  unfolding diagonal_step_def unfolding diagonal_step_row_def[abs_def]
  by auto

text‹Code equation to avoid recalculations when computing the Bezout coefficients. ›
lemma euclid_ext2_code[code]:
 "euclid_ext2 a b = (let ((p,q),d) = euclid_ext a b in (p,q, - b div d, a div d, d))"
  unfolding euclid_ext2_def split_beta Let_def 
  by auto

subsection‹Examples of execution›

value "let A= list_of_list_to_matrix [[12,0,0::int],[0,6,0::int],[0,0,2::int]]::int^3^3 
  in matrix_to_list_of_list (diagonal_to_Smith A euclid_ext2)"

text‹Example obtained from:
\url{https://math.stackexchange.com/questions/77063/how-do-i-get-this-matrix-in-smith-normal-form-and-is-smith-normal-form-unique}
›

value "let A= list_of_list_to_matrix 
    [
    [[:-3,1:],0,0,0],
    [0,[:1,1:],0,0],
    [0,0,[:1,1:],0],
    [0,0,0,[:1,1:]]]::rat poly^4^4 
  in matrix_to_list_of_list (diagonal_to_Smith A euclid_ext2)"


text‹Polynomial matrix›
value "let A = list_of_list_to_matrix 
      [
        [[:-3,1:],0,0,0],
        [0,[:1,1:],0,0],
        [0,0,[:1,1:],0],
        [0,0,0,[:1,1:]],
        [0,0,0,0]]::rat poly^4^5 
  in matrix_to_list_of_list (diagonal_to_Smith A euclid_ext2)"


subsection‹Soundness of the algorithm›

lemma nrows_diagonal_step[simp]: "nrows (diagonal_step A i j c v) = nrows A"
  by (simp add: nrows_def)

lemma ncols_diagonal_step[simp]: "ncols (diagonal_step A i j c v) = ncols A"
  by (simp add: ncols_def)


context
  fixes bezout::"'a::{bezout_ring}  'a  'a × 'a × 'a × 'a × 'a"
  assumes ib: "is_bezout_ext bezout"
begin

lemma split_beta_bezout: "bezout a b = 
  (fst(bezout a b),
  fst (snd (bezout a b)),
  fst (snd(snd (bezout a b))),
  fst (snd(snd(snd (bezout a b)))),
  snd (snd(snd(snd (bezout a b)))))" unfolding split_beta by (auto simp add: split_beta)

text‹The following lemma shows that @{text "diagonal_to_Smith_i"} preserves the previous element. 
  We use the assumption @{text "to_nat a = to_nat b"} in order to ensure that we are treating with 
  a diagonal entry. Since the matrix could be rectangular, the types of a and b can be different, 
  and thus we cannot write either @{text "a = b"} or @{text "A $ a $ b"}.›

lemma diagonal_to_Smith_i_preserves_previous_diagonal:
  fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type"
  assumes i_min: "i < min (nrows A) (ncols A)" 
  and "to_nat a  set xs" and "to_nat a = to_nat b"
  and "to_nat a  i"
  and elements_xs_range: "x. x  set xs  x<min (nrows A) (ncols A)"
  shows "(diagonal_to_Smith_i xs A i bezout) $ a $ b = A $ a $ b" 
  using assms
proof (induct xs A i bezout rule: diagonal_to_Smith_i.induct)
  case (1 A i bezout)
  then show ?case by auto
next
  case (2 j xs A i bezout)   
  let ?Aii = "A $ from_nat i $ from_nat i"
  let ?Ajj = "A $ from_nat j $ from_nat j"
  let ?p="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  p"  
  let ?q="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  q"
  let ?u="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  u"
  let ?v="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  v"
  let ?d="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  d"
  let ?A'="diagonal_step A i j ?d ?v" 
  have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j)"
    by (simp add: split_beta)
  show ?case
  proof (cases "?Aii dvd ?Ajj")
    case True
    then show ?thesis
      using "2.hyps" "2.prems" by auto
  next
    case False
    note i_min = 2(3)
    note hyp = 2(2)
    note i_notin = 2(4)
    note a_eq_b = "2.prems"(3)
    note elements_xs = 2(7)
    note a_not_i = 2(6)    
    have a_not_j: "a  from_nat j"
      by (metis elements_xs i_notin list.set_intros(1) min_less_iff_conj nrows_def to_nat_from_nat_id)
    have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout"
      using False by (auto simp add: split_beta)
    also have "... $ a $ b = ?A' $ a $ b" 
      by (rule hyp[OF False], insert i_notin i_min a_eq_b a_not_i pquvd elements_xs, auto)
    also have "... = A $ a $ b"
      unfolding diagonal_step_def
      using a_not_j a_not_i
      by (smt i_min min.strict_boundedE nrows_def to_nat_from_nat_id vec_lambda_beta)
    finally show ?thesis .
  qed
qed

lemma diagonal_step_dvd1[simp]:
  fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type" and j i
  defines "v==case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  v"
  and "d==case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  d"
 shows "diagonal_step A i j d v $ from_nat i $ from_nat i dvd A $ from_nat i $ from_nat i"
  using ib unfolding is_bezout_ext_def diagonal_step_def v_def d_def 
  by (auto simp add: split_beta)

lemma diagonal_step_dvd2[simp]:
  fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type" and j i
  defines "v==case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  v"
  and "d==case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  d"
 shows "diagonal_step A i j d v $ from_nat i $ from_nat i dvd A $ from_nat j $ from_nat j"
  using ib unfolding is_bezout_ext_def diagonal_step_def v_def d_def 
  by (auto simp add: split_beta)

end

text‹Once the step is carried out, the new element ${A'}_{ii}$ will divide the element $A_{ii}$›

lemma diagonal_to_Smith_i_dvd_ii:
  fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
  assumes ib: "is_bezout_ext bezout"
  shows "diagonal_to_Smith_i xs A i bezout $ from_nat i $ from_nat i dvd A $ from_nat i $ from_nat i"
  using ib
proof (induct xs A i bezout rule: diagonal_to_Smith_i.induct)
  case (1 A i bezout)
  then show ?case by auto
next
  case (2 j xs A i bezout)   
  let ?Aii = "A $ from_nat i $ from_nat i"
  let ?Ajj = "A $ from_nat j $ from_nat j"
  let ?p="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  p"  
  let ?q="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  q"
  let ?u="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  u"
  let ?v="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  v"
  let ?d="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  d"
  let ?A'="diagonal_step A i j ?d ?v" 
  have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j)"
    by (simp add: split_beta)
  note ib = "2.prems"(1) 
  show ?case
  proof (cases "?Aii dvd ?Ajj")
    case True
    then show ?thesis 
      using "2.hyps"(1) "2.prems" by auto
  next
    case False
    note hyp = "2.hyps"(2)    
    have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout" 
      using False by (auto simp add: split_beta)
    also have "... $ from_nat i $ from_nat i dvd ?A' $ from_nat i $ from_nat i"
      by (rule hyp[OF False], insert pquvd ib, auto)
    also have "... dvd A $ from_nat i $ from_nat i" 
      unfolding diagonal_step_def using ib unfolding is_bezout_ext_def
      by (auto simp add: split_beta) 
    finally show ?thesis .
  qed
qed

text‹Once the step is carried out, the new element ${A'}_{ii}$ 
  divides the rest of elements of the diagonal. This proof requires commutativity (already
  included in the type restriction @{text "bezout_ring"}).›

lemma diagonal_to_Smith_i_dvd_jj:
  fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
  assumes ib: "is_bezout_ext bezout"
  and i_min: "i < min (nrows A) (ncols A)" 
  and elements_xs_range: "x. x  set xs  x<min (nrows A) (ncols A)"
  and "to_nat a  set xs"
  and "to_nat a = to_nat b"
  and "to_nat a  i"
  and "distinct xs"
shows "(diagonal_to_Smith_i xs A i bezout) $ (from_nat i) $ (from_nat i) 
       dvd (diagonal_to_Smith_i xs A i bezout) $ a $ b"   
  using assms
proof (induct xs A i bezout rule: diagonal_to_Smith_i.induct)
  case (1 A i)
  then show ?case by auto
next
  case (2 j xs A i bezout)     
  let ?Aii = "A $ from_nat i $ from_nat i"
  let ?Ajj = "A $ from_nat j $ from_nat j"
  let ?p="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  p"  
  let ?q="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  q"
  let ?u="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  u"
  let ?v="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  v"
  let ?d="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  d"
  let ?A'="diagonal_step A i j ?d ?v" 
  have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j)"
    by (simp add: split_beta)
  note ib = "2.prems"(1) 
  note to_nat_a_not_i = 2(8)
  note i_min = 2(4)  
  note elements_xs = "2.prems"(3)
  note a_eq_b = "2.prems"(5)
  note a_in_j_xs = 2(6)
  note distinct = 2(9)
  show ?case
  proof (cases "?Aii dvd ?Ajj")    
    case True note Aii_dvd_Ajj = True
    show ?thesis 
    proof (cases "to_nat a = j")
      case True
      have a: "a = (from_nat j::'c)" using True by auto
      have b: "b = (from_nat j::'b)"
        using True a_eq_b by auto
      have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs A i bezout" 
        using Aii_dvd_Ajj by auto
      also have "... $ from_nat j $ from_nat j = A $ from_nat j $ from_nat j" 
      proof (rule diagonal_to_Smith_i_preserves_previous_diagonal[OF ib i_min])          
        show "to_nat (from_nat j::'c)  set xs" using True a_in_j_xs distinct by auto
        show "to_nat (from_nat j::'c) = to_nat (from_nat j::'b)"
          by (metis True a_eq_b from_nat_to_nat_id)
        show "to_nat (from_nat j::'c)  i"
          using True to_nat_a_not_i by auto
        show "x. x  set xs  x < min (nrows A) (ncols A)" using elements_xs by auto
      qed
      finally have "diagonal_to_Smith_i (j # xs) A i bezout $ from_nat j $ from_nat j 
        = A $ from_nat j $ from_nat j " .
      hence "diagonal_to_Smith_i (j # xs) A i bezout $ a $ b = ?Ajj" unfolding a b .
      moreover have "diagonal_to_Smith_i (j # xs) A i bezout $ from_nat i $ from_nat i dvd ?Aii" 
        by (rule diagonal_to_Smith_i_dvd_ii[OF ib])
      ultimately show ?thesis using Aii_dvd_Ajj dvd_trans by auto
    next
      case False
      have a_in_xs: "to_nat a  set xs" using False using "2.prems"(4) by auto
      have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs A i bezout" 
        using True by auto
      also have "...  $ (from_nat i) $ (from_nat i) dvd diagonal_to_Smith_i xs A i bezout $ a $ b" 
        by (rule "2.hyps"(1)[OF True ib i_min _ a_in_xs a_eq_b to_nat_a_not_i]) 
           (insert elements_xs distinct, auto)
      finally show ?thesis .
    qed
  next
    case False note Aii_not_dvd_Ajj = False    
    show ?thesis
    proof (cases "to_nat a  set xs")
      case True note a_in_xs = True    
      have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout" 
        using False by (auto simp add: split_beta)
      also have "... $ from_nat i $ from_nat i dvd diagonal_to_Smith_i xs ?A' i bezout $ a $ b"
        by (rule "2.hyps"(2)[OF False _ _ _ _ _ _ _ _ _ a_in_xs a_eq_b to_nat_a_not_i ])
           (insert elements_xs distinct i_min ib pquvd, auto simp add: nrows_def ncols_def)    
      finally show ?thesis .    
    next
      case False
      have to_nat_a_eq_j: "to_nat a = j"
        using False a_in_j_xs by auto
      have a: "a = (from_nat j::'c)" using to_nat_a_eq_j by auto
      have b: "b = (from_nat j::'b)" using to_nat_a_eq_j a_eq_b by auto
      have d_eq: "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout" 
        using Aii_not_dvd_Ajj by (simp add: split_beta)
      also have "... $ a $ b = ?A' $ a $ b"
        by (rule diagonal_to_Smith_i_preserves_previous_diagonal[OF ib _ False a_eq_b to_nat_a_not_i])
           (insert i_min elements_xs ib, auto)
      finally have "diagonal_to_Smith_i (j # xs) A i bezout $ a $ b = ?A' $ a $ b" .
      moreover have "diagonal_to_Smith_i (j # xs) A i bezout $ from_nat i $ from_nat i 
        dvd ?A' $ from_nat i $ from_nat i" 
        using d_eq diagonal_to_Smith_i_dvd_ii[OF ib] by simp
      moreover have "?A' $ from_nat i $ from_nat i dvd ?A' $ from_nat j $ from_nat j" 
        unfolding diagonal_step_def using ib unfolding is_bezout_ext_def split_beta
        by (auto, meson dvd_mult)+      
      ultimately show ?thesis using dvd_trans a b by auto        
  qed
qed
qed


text‹The step preserves everything that is not in the diagonal›

lemma diagonal_to_Smith_i_preserves_previous:
  fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type"
  assumes ib: "is_bezout_ext bezout"
    and i_min: "i < min (nrows A) (ncols A)"
  and a_not_b: "to_nat a  to_nat b"
  and elements_xs_range: "x. x  set xs  x<min (nrows A) (ncols A)"
  shows "(diagonal_to_Smith_i xs A i bezout) $ a $ b = A $ a $ b" 
  using assms
proof (induct xs A i bezout rule: diagonal_to_Smith_i.induct)
case (1 A i)
  then show ?case by auto
next  
  case (2 j xs A i bezout)     
  let ?Aii = "A $ from_nat i $ from_nat i"
  let ?Ajj = "A $ from_nat j $ from_nat j"
  let ?p="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  p"  
  let ?q="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  q"
  let ?u="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  u"
  let ?v="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  v"
  let ?d="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  d"
  let ?A'="diagonal_step A i j ?d ?v" 
  have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j)"
    by (simp add: split_beta)
  note ib = "2.prems"(1) 
  show ?case
  proof (cases "?Aii dvd ?Ajj")
    case True
    then show ?thesis 
      using "2.hyps"(1) "2.prems" by auto
  next
    case False
    note hyp = "2.hyps"(2)
    have a1: "a = from_nat i  b  from_nat i" 
      by (metis "2.prems" a_not_b from_nat_not_eq min.strict_boundedE ncols_def nrows_def)
    have a2: "a = from_nat j  b  from_nat j"       
      by (metis "2.prems" a_not_b list.set_intros(1) min_less_iff_conj 
          ncols_def nrows_def to_nat_from_nat_id)
    have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout" 
      using False by (simp add: split_beta)
    also have "... $ a $ b = ?A' $ a $ b"
      by (rule hyp[OF False], insert "2.prems" ib pquvd, auto)
    also have "... = A $ a $ b" unfolding diagonal_step_def using a1 a2 by auto
    finally show ?thesis .
  qed
qed


lemma diagonal_step_preserves:
  fixes A::"'a::{times}^'b::mod_type^'c::mod_type"
  assumes ai: "a  i" and aj: "a  j" and a_min: "a < min (nrows A) (ncols A)" 
    and i_min: "i < min (nrows A) (ncols A)"
  and j_min: "j < min (nrows A) (ncols A)"
  shows "diagonal_step A i j d v $ from_nat a $ from_nat b = A $ from_nat a $ from_nat b"
proof -
  have 1: "(from_nat a::'c)  from_nat i"
    by (metis a_min ai from_nat_eq_imp_eq i_min min.strict_boundedE nrows_def)
  have 2: "(from_nat a::'c)  from_nat j"
    by (metis a_min aj from_nat_eq_imp_eq j_min min.strict_boundedE nrows_def)
  show ?thesis
    using 1 2 unfolding diagonal_step_def by auto
qed

context GCD_ring
begin

lemma gcd_greatest: 
  assumes "is_gcd gcd'" and "c dvd a" and "c dvd b" 
  shows "c dvd gcd' a b" 
  using assms is_gcd_def by blast

end


text‹This is a key lemma for the soundness of the algorithm.›

lemma diagonal_to_Smith_i_dvd:
  fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type"
  assumes ib: "is_bezout_ext bezout"
  and i_min: "i < min (nrows A) (ncols A)"
  and elements_xs_range: "x. x  set xs  x<min (nrows A) (ncols A)"
  and "a b. to_nat ainsert i (set xs)  to_nat a = to_nat b  
      A $ (from_nat c) $ (from_nat c) dvd A $ a $ b"
  and "c  (set xs)" and c: "c<min (nrows A) (ncols A)"
  and "distinct xs"
  shows "A $ (from_nat c) $ (from_nat c) dvd 
  (diagonal_to_Smith_i xs A i bezout) $ (from_nat i) $ (from_nat i)" 
  using assms
proof (induct xs A i bezout rule: diagonal_to_Smith_i.induct)
  case (1 A i)
  then show ?case
    by (auto simp add: ncols_def nrows_def to_nat_from_nat_id)
next
  case (2 j xs A i bezout)
  let ?Aii = "A $ from_nat i $ from_nat i"
  let ?Ajj = "A $ from_nat j $ from_nat j"
  let ?p="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  p"  
  let ?q="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  q"
  let ?u="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  u"
  let ?v="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  v"
  let ?d="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  d"
  let ?A'="diagonal_step A i j ?d ?v" 
  have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j)"
    by (simp add: split_beta)
  note ib = "2.prems"(1) 
  show ?case
  proof (cases "?Aii dvd ?Ajj")    
    case True note Aii_dvd_Ajj = True
    show ?thesis using True
      using "2.hyps" "2.prems" by force      
  next
    case False 
    let ?Acc = "A $ from_nat c $ from_nat c" 
    let ?D="diagonal_step A i j ?d ?v"
    note hyp = "2.hyps"(2)  
    note dvd_condition = "2.prems"(4)
    note a_eq_b = "2.hyps"
    have 1: "(from_nat c::'c)  from_nat i"
      by (metis "2.prems" False c insert_iff list.set_intros(1) 
          min.strict_boundedE ncols_def nrows_def to_nat_from_nat_id)
    have 2: "(from_nat c::'c)  from_nat j"
      by (metis  "2.prems" c insertI1 list.simps(15) min_less_iff_conj nrows_def 
          to_nat_from_nat_id)       
    have "?D $ from_nat c $ from_nat c = ?Acc"
      unfolding diagonal_step_def using 1 2 by auto
    have aux: "?D $ from_nat c $ from_nat c dvd ?D $ a $ b"
      if a_in_set: "to_nat a  insert i (set xs)" and ab: "to_nat a = to_nat b" for a b      
    proof -
     have Acc_dvd_Aii: "?Acc dvd ?Aii"
       by (metis "2.prems"(2) "2.prems"(4) insert_iff min.strict_boundedE 
           ncols_def nrows_def to_nat_from_nat_id)
     moreover have Acc_dvd_Ajj: "?Acc dvd ?Ajj"
       by (metis "2.prems"(3) "2.prems"(4) insert_iff list.set_intros(1) 
           min_less_iff_conj ncols_def nrows_def to_nat_from_nat_id)
     ultimately have Acc_dvd_gcd: "?Acc dvd ?d"
       by (metis (mono_tags, lifting) ib is_gcd_def is_gcd_is_bezout_ext)
     show ?thesis 
      using 1 2 Acc_dvd_Ajj Acc_dvd_Aii Acc_dvd_gcd a_in_set ab dvd_condition 
      unfolding diagonal_step_def by auto     
  qed   
    have "?A' $ from_nat c $ from_nat c = A $ from_nat c $ from_nat c" 
      unfolding diagonal_step_def using 1 2 by auto
    moreover have "?A' $ from_nat c $ from_nat c 
      dvd diagonal_to_Smith_i xs ?A' i bezout $ from_nat i $ from_nat i"
      by (rule hyp[OF False _ _ _ _ _ _ ib]) 
         (insert nrows_def ncols_def "2.prems" "2.hyps" aux pquvd, auto)
    ultimately show ?thesis using False by (auto simp add: split_beta)
  qed
qed


lemma diagonal_to_Smith_i_dvd2:
  fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type"
  assumes ib: "is_bezout_ext bezout" 
  and i_min: "i < min (nrows A) (ncols A)"
  and elements_xs_range: "x. x  set xs  x<min (nrows A) (ncols A)"
  and dvd_condition: "a b. to_nat a  insert i (set xs)  to_nat a = to_nat b  
      A $ (from_nat c) $ (from_nat c) dvd A $ a $ b"
  and c_notin: "c  (set xs)" 
  and c: "c < min (nrows A) (ncols A)"
  and distinct: "distinct xs"
  and ab: "to_nat a = to_nat b" 
  and a_in: "to_nat a  insert i (set xs)"
  shows "A $ (from_nat c) $ (from_nat c) dvd (diagonal_to_Smith_i xs A i bezout) $ a $ b" 
proof (cases "a = from_nat i")
  case True
  hence b: "b = from_nat i"
    by (metis ab from_nat_to_nat_id i_min min_less_iff_conj nrows_def to_nat_from_nat_id)
  show ?thesis by (unfold True b, rule diagonal_to_Smith_i_dvd, insert assms, auto)
next
  case False
  have ai: "to_nat a  i" using False by auto
  hence bi: "to_nat b  i" by (simp add: ab)
  have "A $ (from_nat c) $ (from_nat c) dvd (diagonal_to_Smith_i xs A i bezout) $ from_nat i $ from_nat i"
    by (rule diagonal_to_Smith_i_dvd, insert assms, auto)
  also have "... dvd (diagonal_to_Smith_i xs A i bezout) $ a $ b" 
    by (rule diagonal_to_Smith_i_dvd_jj, insert assms False ai bi, auto)
  finally show ?thesis .
qed


lemma diagonal_to_Smith_i_dvd2_k:
  fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
  assumes ib: "is_bezout_ext bezout" 
  and i_min: "i < min (nrows A) (ncols A)"
  and elements_xs_range: "x. x  set xs  x<k" and "kmin (nrows A) (ncols A)"
  and dvd_condition: "a b. to_nat a  insert i (set xs)  to_nat a = to_nat b  
      A $ (from_nat c) $ (from_nat c) dvd A $ a $ b"
  and c_notin: "c  (set xs)" 
  and c: "c < min (nrows A) (ncols A)"
  and distinct: "distinct xs"
  and ab: "to_nat a = to_nat b" 
  and a_in: "to_nat a  insert i (set xs)"
  shows "A $ (from_nat c) $ (from_nat c) dvd (diagonal_to_Smith_i xs A i bezout) $ a $ b" 
proof (cases "a = from_nat i")
  case True
  hence b: "b = from_nat i"
    by (metis ab from_nat_to_nat_id i_min min_less_iff_conj nrows_def to_nat_from_nat_id)
  show ?thesis by (unfold True b, rule diagonal_to_Smith_i_dvd, insert assms, auto)
next
  case False
  have ai: "to_nat a  i" using False by auto
  hence bi: "to_nat b  i" by (simp add: ab)
  have "A $ (from_nat c) $ (from_nat c) dvd (diagonal_to_Smith_i xs A i bezout) $ from_nat i $ from_nat i"
    by (rule diagonal_to_Smith_i_dvd, insert assms, auto)
  also have "... dvd (diagonal_to_Smith_i xs A i bezout) $ a $ b" 
    by (rule diagonal_to_Smith_i_dvd_jj, insert assms False ai bi, auto)
  finally show ?thesis .
qed



lemma diagonal_to_Smith_row_i_preserves_previous:
  fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type"
  assumes ib: "is_bezout_ext bezout"
  and i_min: "i < min (nrows A) (ncols A)"
  and a_not_b: "to_nat a  to_nat b"  
  shows "Diagonal_to_Smith_row_i A i bezout $ a $ b = A $ a $ b" 
    unfolding Diagonal_to_Smith_row_i_def
    by (rule diagonal_to_Smith_i_preserves_previous, insert assms, auto)


lemma diagonal_to_Smith_row_i_preserves_previous_diagonal:
  fixes A::"'a:: {bezout_ring}^'b::mod_type^'c::mod_type"
  assumes ib: "is_bezout_ext bezout"
  and i_min: "i < min (nrows A) (ncols A)"  
  and a_notin: "to_nat a  set [i + 1..<min (nrows A) (ncols A)]"
  and ab: "to_nat a = to_nat b"
  and ai: "to_nat a  i" 
  shows "Diagonal_to_Smith_row_i A i bezout $ a $ b = A $ a $ b" 
  unfolding Diagonal_to_Smith_row_i_def
  by (rule diagonal_to_Smith_i_preserves_previous_diagonal[OF ib i_min a_notin ab ai], auto)

context
  fixes bezout::"'a::{bezout_ring}  'a  'a × 'a × 'a × 'a × 'a"
  assumes ib: "is_bezout_ext bezout"
begin

lemma diagonal_to_Smith_row_i_dvd_jj:
  fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
  assumes "to_nat a  {i..<min (nrows A) (ncols A)}"
  and "to_nat a = to_nat b"
  shows "(Diagonal_to_Smith_row_i A i bezout) $ (from_nat i) $ (from_nat i) 
          dvd (Diagonal_to_Smith_row_i A i bezout) $ a $ b"
proof (cases "to_nat a = i")
  case True
  then show ?thesis
    by (metis assms(2) dvd_refl from_nat_to_nat_id)
next
  case False
  show ?thesis 
    unfolding Diagonal_to_Smith_row_i_def 
    by (rule diagonal_to_Smith_i_dvd_jj, insert assms False ib, auto)
qed


lemma diagonal_to_Smith_row_i_dvd_ii:
  fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
  shows "Diagonal_to_Smith_row_i A i bezout $ from_nat i $ from_nat i dvd A $ from_nat i $ from_nat i"
  unfolding Diagonal_to_Smith_row_i_def
  by (rule diagonal_to_Smith_i_dvd_ii[OF ib])


lemma diagonal_to_Smith_row_i_dvd_jj':
  fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
  assumes a_in: "to_nat a  {i..<min (nrows A) (ncols A)}"
  and ab: "to_nat a = to_nat b" 
  and ci: "ci"
  and dvd_condition: "a b. to_nat a  (set [i..<min (nrows A) (ncols A)])  to_nat a = to_nat b 
     A $ from_nat c $ from_nat c dvd A $ a $ b"
  shows "(Diagonal_to_Smith_row_i A i bezout) $ (from_nat c) $ (from_nat c) 
          dvd (Diagonal_to_Smith_row_i A i bezout) $ a $ b"
proof (cases "c = i")
  case True
  then show ?thesis using assms True diagonal_to_Smith_row_i_dvd_jj
    by metis
  next
  case False
  hence ci2: "c<i" using ci by auto
  have 1: "to_nat (from_nat c::'c)  (set [i+1..<min (nrows A) (ncols A)])"    
    by (metis Suc_eq_plus1 ci atLeastLessThan_iff from_nat_mono 
        le_imp_less_Suc less_irrefl less_le_trans set_upt to_nat_le to_nat_less_card)
  have 2: "to_nat (from_nat c)  i"
    using ci2 from_nat_mono to_nat_less_card by fastforce
  have 3: "to_nat (from_nat c::'c) = to_nat (from_nat c::'b)"
    by (metis a_in ab atLeastLessThan_iff ci dual_order.strict_trans2 to_nat_from_nat_id to_nat_less_card)
  have "(Diagonal_to_Smith_row_i A i bezout) $ (from_nat c) $ (from_nat c) 
    = A $(from_nat c) $ (from_nat c)"
    unfolding Diagonal_to_Smith_row_i_def 
    by (rule diagonal_to_Smith_i_preserves_previous_diagonal[OF ib _ 1 3 2], insert assms, auto)
  also have "... dvd (Diagonal_to_Smith_row_i A i bezout) $ a $ b"
    unfolding Diagonal_to_Smith_row_i_def 
    by (rule diagonal_to_Smith_i_dvd2, insert assms False ci ib, auto)  
  finally show ?thesis .
qed
end


lemma diagonal_to_Smith_aux_append:
  "diagonal_to_Smith_aux A (xs @ ys) bezout 
    = diagonal_to_Smith_aux (diagonal_to_Smith_aux A xs bezout) ys bezout"
  by (induct A xs bezout rule: diagonal_to_Smith_aux.induct, auto)
 

lemma diagonal_to_Smith_aux_append2[simp]:
  "diagonal_to_Smith_aux A (xs @ [ys]) bezout 
    = Diagonal_to_Smith_row_i (diagonal_to_Smith_aux A xs bezout) ys bezout"
  by (induct A xs bezout rule: diagonal_to_Smith_aux.induct, auto)  


lemma isDiagonal_eq_upt_k_min:
"isDiagonal A = isDiagonal_upt_k A (min (nrows A) (ncols A))" 
  unfolding isDiagonal_def isDiagonal_upt_k_def nrows_def ncols_def  
  by (auto, meson less_trans not_less_iff_gr_or_eq to_nat_less_card)


lemma isDiagonal_eq_upt_k_max:
"isDiagonal A = isDiagonal_upt_k A (max (nrows A) (ncols A))" 
  unfolding isDiagonal_def isDiagonal_upt_k_def nrows_def ncols_def  
  by (auto simp add: less_max_iff_disj to_nat_less_card)

lemma isDiagonal: 
  assumes "isDiagonal A"
    and "to_nat a  to_nat b" shows "A $ a $ b = 0" 
  using assms unfolding isDiagonal_def by auto

lemma nrows_diagonal_to_Smith_aux[simp]: 
  shows "nrows (diagonal_to_Smith_aux A xs bezout) = nrows A" unfolding nrows_def by auto

lemma ncols_diagonal_to_Smith_aux[simp]:
  shows "ncols (diagonal_to_Smith_aux A xs bezout) = ncols A" unfolding ncols_def by auto

context
  fixes bezout::"'a::{bezout_ring}  'a  'a × 'a × 'a × 'a × 'a"
  assumes ib: "is_bezout_ext bezout"
begin

lemma isDiagonal_diagonal_to_Smith_aux:
  assumes diag_A: "isDiagonal A" and k: "k < min (nrows A) (ncols A)"
  shows "isDiagonal (diagonal_to_Smith_aux A [0..<k] bezout)"
  using k
proof (induct k)
  case 0
  then show ?case using diag_A by auto
next
  case (Suc k)
  have "Diagonal_to_Smith_row_i (diagonal_to_Smith_aux A [0..<k] bezout) k bezout $ a $ b = 0" 
    if a_not_b: "to_nat a  to_nat b" for a b
  proof -
    have "Diagonal_to_Smith_row_i (diagonal_to_Smith_aux A [0..<k] bezout) k bezout $ a $ b 
      = (diagonal_to_Smith_aux A [0..<k] bezout) $ a $ b"
      by (rule diagonal_to_Smith_row_i_preserves_previous[OF ib _ a_not_b], insert Suc.prems, auto)
    also have "... = 0" 
      by (rule isDiagonal[OF Suc.hyps a_not_b], insert Suc.prems, auto)
    finally show ?thesis .
  qed
  thus ?case unfolding isDiagonal_def by auto
qed
end

(*TODO: move!*)
lemma to_nat_less_nrows[simp]:
  fixes A::"'a^'b::mod_type^'c::mod_type"
    and a::'c
  shows "to_nat a < nrows A"
  by (simp add: nrows_def to_nat_less_card)

lemma to_nat_less_ncols[simp]:
  fixes A::"'a^'b::mod_type^'c::mod_type"
    and a::'b
  shows "to_nat a < ncols A"
  by (simp add: ncols_def to_nat_less_card)

context
  fixes bezout::"'a::{bezout_ring}  'a  'a × 'a × 'a × 'a × 'a"
  assumes ib: "is_bezout_ext bezout"
begin

text‹The variables a and b must be arbitrary in the induction›
lemma diagonal_to_Smith_aux_dvd:
  fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
  assumes ab: "to_nat a = to_nat b"
  and c: "c < k" and ca: "c  to_nat a" and k: "k<min (nrows A) (ncols A)"
  shows "diagonal_to_Smith_aux A [0..<k] bezout $ from_nat c $ from_nat c
    dvd diagonal_to_Smith_aux A [0..<k] bezout $ a $ b"
  using c ab ca k
proof (induct k arbitrary: a b)
  case 0
  then show ?case by auto
next
  case (Suc k)
  note c = Suc.prems(1)
  note ab = Suc.prems(2)
  note ca = Suc.prems(3)
  note k = Suc.prems(4)
  have k_min: "k < min (nrows A) (ncols A)" using k by auto
  have a_less_ncols: "to_nat a < ncols A" using ab by auto
  show ?case
  proof (cases "c=k")
    case True
    hence k: "kto_nat a" using ca by auto
    show ?thesis unfolding True
      by (auto, rule diagonal_to_Smith_row_i_dvd_jj[OF ib _ ab], insert k a_less_ncols, auto)  
  next
    case False note c_not_k = False
    let ?Dk="diagonal_to_Smith_aux A [0..<k] bezout"
    have ck: "c<k" using Suc.prems False by auto
    have hyp: "?Dk $ from_nat c $ from_nat c dvd ?Dk $ a $ b" 
      by (rule Suc.hyps[OF ck ab ca k_min])
    have Dkk_Daa_bb: "?Dk $ from_nat c $ from_nat c dvd ?Dk $ aa $ bb"
      if "to_nat aa  set [k..<min (nrows ?Dk) (ncols ?Dk)]" and "to_nat aa = to_nat bb"
      for aa bb using Suc.hyps ck k_min that(1) that(2) by auto
    show ?thesis  
    proof (cases "kto_nat a")
      case True
      show ?thesis
        by (auto, rule diagonal_to_Smith_row_i_dvd_jj'[OF ib _ ab]) 
           (insert True a_less_ncols ck Dkk_Daa_bb, force+)       
    next
      case False
      have "diagonal_to_Smith_aux A [0..<Suc k] bezout $ from_nat c $ from_nat c 
        = Diagonal_to_Smith_row_i ?Dk k bezout $ from_nat c $ from_nat c" by auto
      also have "... = ?Dk $ from_nat c $ from_nat c" 
      proof (rule diagonal_to_Smith_row_i_preserves_previous_diagonal[OF ib])
        show "k < min (nrows ?Dk) (ncols ?Dk)" using k by auto
        show "to_nat (from_nat c::'c) = to_nat (from_nat c::'b)"
          by (metis assms(2) assms(4) less_trans min_less_iff_conj 
             ncols_def nrows_def to_nat_from_nat_id)
        show "to_nat (from_nat c::'c)  k"
          using False ca from_nat_mono' to_nat_less_card to_nat_mono' by fastforce      
        show "to_nat (from_nat c::'c)  set [k + 1..<min (nrows ?Dk) (ncols ?Dk)]"
          by (metis Suc_eq_plus1 atLeastLessThan_iff c ca from_nat_not_eq 
              le_less_trans not_le set_upt to_nat_less_card)
      qed
      also have "... dvd ?Dk $ a $ b" using hyp .
      also have "... = Diagonal_to_Smith_row_i ?Dk k bezout $ a $ b"
        by (rule diagonal_to_Smith_row_i_preserves_previous_diagonal[symmetric, OF ib _ _ ab])
           (insert False k, auto)
      also have "... = diagonal_to_Smith_aux A [0..<Suc k] bezout $ a $ b" by auto
      finally show ?thesis .
    qed
  qed
qed


lemma Smith_normal_form_upt_k_Suc_imp_k:
  fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
  assumes s: "Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0..<Suc k] bezout) k"
  and k: "k<min (nrows A) (ncols A)"
  shows "Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0..<k] bezout) k"
proof (rule Smith_normal_form_upt_k_intro) 
  let ?Dk="diagonal_to_Smith_aux A [0..<k] bezout"
  fix a::'c and b::'b assume "to_nat a = to_nat b  to_nat a + 1 < k  to_nat b + 1 < k"
  hence ab: "to_nat a = to_nat b" and ak: "to_nat a + 1 < k" and bk: "to_nat b + 1 < k" by auto  
  have a_not_k: "to_nat a  k" using ak by auto    
  have a1_less_k1: "to_nat a + 1 < k + 1" using ak by linarith
  have "?Dk $a $ b = diagonal_to_Smith_aux A [0..<Suc k] bezout $ a $ b"
    by (auto, rule diagonal_to_Smith_row_i_preserves_previous_diagonal[symmetric, OF ib _ _ ab a_not_k]) 
       (insert ak k, auto)
  also have "... dvd diagonal_to_Smith_aux A [0..<Suc k] bezout $ (a + 1) $ (b + 1)" 
    using ab ak bk s unfolding Smith_normal_form_upt_k_def by auto
  also have "... = ?Dk $ (a+1) $ (b+1)"
  proof (auto, rule diagonal_to_Smith_row_i_preserves_previous_diagonal[OF ib])
    show "to_nat (a + 1)  k" using ak
      by (metis add_less_same_cancel2 nat_neq_iff not_add_less2 to_nat_0 
         to_nat_plus_one_less_card' to_nat_suc)
    show "to_nat (a + 1) = to_nat (b + 1)"
      by (metis ab ak from_nat_suc from_nat_to_nat_id k less_asym' min_less_iff_conj 
          ncols_def nrows_def suc_not_zero to_nat_from_nat_id to_nat_plus_one_less_card')
    show "to_nat (a + 1)  set [k + 1..<min (nrows ?Dk) (ncols ?Dk)]"      
      by (metis a1_less_k1 add_to_nat_def atLeastLessThan_iff k less_asym' min.strict_boundedE 
          not_less nrows_def set_upt suc_not_zero to_nat_1 to_nat_from_nat_id to_nat_plus_one_less_card')
    show "k < min (nrows ?Dk) (ncols ?Dk)" using k by auto
  qed
  finally show "?Dk $ a $ b dvd ?Dk $ (a+1) $ (b+1)" .
next
  let ?Dk="diagonal_to_Smith_aux A [0..<k] bezout"
  fix a::'c and b::'b
  assume "to_nat a  to_nat b  (to_nat a < k  to_nat b < k)" 
  hence ab: "to_nat a  to_nat b" and ak_bk: "(to_nat a < k  to_nat b < k)" by auto
  have "?Dk $a $ b = diagonal_to_Smith_aux A [0..<Suc k] bezout $ a $ b"
    by (auto, rule diagonal_to_Smith_row_i_preserves_previous[symmetric, OF ib _ ab], insert k, auto)
  also have "... = 0"
    using ab ak_bk s unfolding Smith_normal_form_upt_k_def isDiagonal_upt_k_def 
    by auto
  finally show "?Dk $ a $ b = 0" .
qed


lemma Smith_normal_form_upt_k_le:
  assumes "ak" and "Smith_normal_form_upt_k A k"
  shows "Smith_normal_form_upt_k A a" using assms
  by (smt Smith_normal_form_upt_k_def isDiagonal_upt_k_def less_le_trans)

lemma Smith_normal_form_upt_k_imp_Suc_k:
  assumes s: "Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0..<k] bezout) k"
  and k: "k<min (nrows A) (ncols A)"
  shows "Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0..<Suc k] bezout) k"
proof (rule Smith_normal_form_upt_k_intro)
  let ?Dk="diagonal_to_Smith_aux A [0..<k] bezout"
  fix a::'c and b::'b assume "to_nat a = to_nat b  to_nat a + 1 < k  to_nat b + 1 < k"
  hence ab: "to_nat a = to_nat b" and ak: "to_nat a + 1 < k" and bk: "to_nat b + 1 < k" by auto
  have a_not_k: "to_nat a  k" using ak by auto    
  have a1_less_k1: "to_nat a + 1 < k + 1" using ak by linarith
  have "diagonal_to_Smith_aux A [0..<Suc k] bezout $ a $ b = ?Dk $a $ b"
    by (auto, rule diagonal_to_Smith_row_i_preserves_previous_diagonal[OF ib _ _ ab a_not_k]) 
       (insert ak k, auto)
  also have "... dvd ?Dk $ (a+1) $ (b+1)"
    using s ak k ab unfolding Smith_normal_form_upt_k_def by auto
  also have "... = diagonal_to_Smith_aux A [0..<Suc k] bezout $ (a + 1) $ (b + 1)" 
  proof (auto, rule diagonal_to_Smith_row_i_preserves_previous_diagonal[symmetric, OF ib])
    show "to_nat (a + 1)  k" using ak
      by (metis add_less_same_cancel2 nat_neq_iff not_add_less2 to_nat_0 
         to_nat_plus_one_less_card' to_nat_suc)
    show "to_nat (a + 1) = to_nat (b + 1)"
      by (metis ab ak from_nat_suc from_nat_to_nat_id k less_asym' min_less_iff_conj 
          ncols_def nrows_def suc_not_zero to_nat_from_nat_id to_nat_plus_one_less_card')
    show "to_nat (a + 1)  set [k + 1..<min (nrows ?Dk) (ncols ?Dk)]"      
      by (metis a1_less_k1 add_to_nat_def to_nat_plus_one_less_card' less_asym' min.strict_boundedE 
          not_less nrows_def set_upt suc_not_zero to_nat_1 to_nat_from_nat_id atLeastLessThan_iff k)
    show "k < min (nrows ?Dk) (ncols ?Dk)" using k by auto
  qed
  finally show "diagonal_to_Smith_aux A [0..<Suc k] bezout $ a $ b 
    dvd diagonal_to_Smith_aux A [0..<Suc k] bezout $ (a + 1) $ (b + 1)" .
next
  let ?Dk="diagonal_to_Smith_aux A [0..<k] bezout"
  fix a::'c and b::'b
  assume "to_nat a  to_nat b  (to_nat a < k  to_nat b < k)" 
  hence ab: "to_nat a  to_nat b" and ak_bk: "(to_nat a < k  to_nat b < k)" by auto
  have "diagonal_to_Smith_aux A [0..<Suc k] bezout $ a $ b = ?Dk $a $ b"
    by (auto, rule diagonal_to_Smith_row_i_preserves_previous[OF ib _ ab], insert k, auto)
  also have "... = 0"
    using ab ak_bk s unfolding Smith_normal_form_upt_k_def isDiagonal_upt_k_def 
    by auto
  finally show "diagonal_to_Smith_aux A [0..<Suc k] bezout $ a $ b = 0" .
qed

corollary Smith_normal_form_upt_k_Suc_eq:
  assumes k: "k<min (nrows A) (ncols A)"
  shows "Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0..<Suc k] bezout) k 
    = Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0..<k] bezout) k"  
  using Smith_normal_form_upt_k_Suc_imp_k Smith_normal_form_upt_k_imp_Suc_k k 
  by blast

end

lemma nrows_diagonal_to_Smith_i[simp]: "nrows (diagonal_to_Smith_i xs A i bezout) = nrows A"
  by (induct xs A i bezout rule: diagonal_to_Smith_i.induct, auto simp add: nrows_def)

lemma ncols_diagonal_to_Smith_i[simp]: "ncols (diagonal_to_Smith_i xs A i bezout) = ncols A"
  by (induct xs A i bezout rule: diagonal_to_Smith_i.induct, auto simp add: ncols_def)

lemma nrows_Diagonal_to_Smith_row_i[simp]: "nrows (Diagonal_to_Smith_row_i A i bezout) = nrows A" 
  unfolding Diagonal_to_Smith_row_i_def by auto

lemma ncols_Diagonal_to_Smith_row_i[simp]: "ncols (Diagonal_to_Smith_row_i A i bezout) = ncols A" 
  unfolding Diagonal_to_Smith_row_i_def by auto

lemma isDiagonal_diagonal_step:
  assumes diag_A: "isDiagonal A" and i: "i<min (nrows A) (ncols A)"
    and j: "j<min (nrows A) (ncols A)"
  shows "isDiagonal (diagonal_step A i j d v)"
proof -
  have i_eq: "to_nat (from_nat i::'b) = to_nat (from_nat i::'c)" using i
    by (simp add: ncols_def nrows_def to_nat_from_nat_id)
  moreover have j_eq: "to_nat (from_nat j::'b) = to_nat (from_nat j::'c)" using j
    by (simp add: ncols_def nrows_def to_nat_from_nat_id)
    ultimately show ?thesis
    using assms
    unfolding isDiagonal_def diagonal_step_def by auto
qed

lemma isDiagonal_diagonal_to_Smith_i:
  assumes "isDiagonal A"
    and elements_xs_range: "x. x  set xs  x<min (nrows A) (ncols A)" 
    and "i<min (nrows A) (ncols A)"
  shows "isDiagonal (diagonal_to_Smith_i xs A i bezout)"
  using assms
proof (induct xs A i bezout rule: diagonal_to_Smith_i.induct)
  case (1 A i bezout)
  then show ?case by auto
next
  case (2 j xs A i bezout)  
  let ?Aii = "A $ from_nat i $ from_nat i"
  let ?Ajj = "A $ from_nat j $ from_nat j"
  let ?p="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  p"  
  let ?q="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  q"
  let ?u="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  u"
  let ?v="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  v"
  let ?d="case bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j) of (p,q,u,v,d)  d"
  let ?A'="diagonal_step A i j ?d ?v" 
  have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j)"
    by (simp add: split_beta)
  show ?case 
  proof (cases "?Aii dvd ?Ajj")
    case True
    thus ?thesis
        using "2.hyps" "2.prems" by auto
  next
    case False
    have "diagonal_to_Smith_i (j # xs) A i bezout = diagonal_to_Smith_i xs ?A' i bezout" 
      using False by (simp add: split_beta) 
    also have "isDiagonal ..." thm "2.prems"
    proof (rule "2.hyps"(2)[OF False])
      show "isDiagonal
        (diagonal_step A i j ?d ?v)" by (rule isDiagonal_diagonal_step, insert "2.prems", auto)
    qed (insert pquvd "2.prems", auto)
    finally show ?thesis .
  qed  
qed


lemma isDiagonal_Diagonal_to_Smith_row_i:
  assumes "isDiagonal A" and "i < min (nrows A) (ncols A)"
  shows "isDiagonal (Diagonal_to_Smith_row_i A i bezout)"   
  using assms isDiagonal_diagonal_to_Smith_i
  unfolding Diagonal_to_Smith_row_i_def by force


lemma isDiagonal_diagonal_to_Smith_aux_general:
  assumes elements_xs_range: "x. x  set xs  x<min (nrows A) (ncols A)" 
  and "isDiagonal A"
shows "isDiagonal (diagonal_to_Smith_aux A xs bezout)"
  using assms
proof (induct A xs bezout rule: diagonal_to_Smith_aux.induct)
  case (1 A)
  then show ?case by auto
next
  case (2 A i xs bezout)  
  note k = "2.prems"(1)
  note elements_xs_range = "2.prems"(2)
  have "diagonal_to_Smith_aux A (i # xs) bezout 
  = diagonal_to_Smith_aux (Diagonal_to_Smith_row_i A i bezout) xs bezout" 
    by auto
  also have "isDiagonal (...)"
    by (rule "2.hyps", insert isDiagonal_Diagonal_to_Smith_row_i "2.prems" k, auto)   
  finally show ?case .
qed

context
  fixes bezout::"'a::{bezout_ring}  'a  'a × 'a × 'a × 'a × 'a"
  assumes ib: "is_bezout_ext bezout"
begin

text‹The algorithm is iterated up to position k (not included). Thus, the matrix
is in Smith normal form up to position k (not included).›

lemma Smith_normal_form_upt_k_diagonal_to_Smith_aux:
  fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
  assumes "k<min (nrows A) (ncols A)" and d: "isDiagonal A"
  shows "Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0..<k] bezout) k"
  using assms
proof (induct k)
  case 0
  then show ?case by auto
next
  case (Suc k)
  note Suc_k = "Suc.prems"(1)
  have hyp: "Smith_normal_form_upt_k (diagonal_to_Smith_aux A [0..<k] bezout) k"
    by (rule Suc.hyps, insert Suc.prems, simp)
  have k: "k < min (nrows A) (ncols A)" using Suc.prems by auto
  let ?A = "diagonal_to_Smith_aux A [0..<k] bezout"
  let ?D_Suck = "diagonal_to_Smith_aux A [0..<Suc k] bezout"
  have set_rw: "[0..<Suc k] = [0..<k] @ [k]" by auto
  show ?case
  proof (rule Smith_normal_form_upt_k1_intro_diagonal)
    show "Smith_normal_form_upt_k (?D_Suck) k"
      by (rule Smith_normal_form_upt_k_imp_Suc_k[OF ib hyp k])
    show "?D_Suck $ from_nat (k - 1) $ from_nat (k - 1) dvd ?D_Suck $ from_nat k $ from_nat k"
    proof (rule diagonal_to_Smith_aux_dvd[OF ib _ _ _ Suc_k])
      show "to_nat (from_nat k::'c) = to_nat (from_nat k::'b)"
        by (metis k min_less_iff_conj ncols_def nrows_def to_nat_from_nat_id)
      show "k - 1  to_nat (from_nat k::'c)"
        by (metis diff_le_self k min_less_iff_conj nrows_def to_nat_from_nat_id)
    qed auto
    show "isDiagonal (diagonal_to_Smith_aux A [0..<Suc k] bezout)"
      by (rule isDiagonal_diagonal_to_Smith_aux[OF ib d Suc_k])
  qed
qed

end

lemma nrows_diagonal_to_Smith[simp]: "nrows (diagonal_to_Smith A bezout) = nrows A"
  unfolding diagonal_to_Smith_def by auto

lemma ncols_diagonal_to_Smith[simp]: "ncols (diagonal_to_Smith A bezout) = ncols A"
  unfolding diagonal_to_Smith_def by auto

lemma isDiagonal_diagonal_to_Smith:
  assumes d: "isDiagonal A"
  shows "isDiagonal (diagonal_to_Smith A bezout)"
  unfolding diagonal_to_Smith_def 
  by (rule isDiagonal_diagonal_to_Smith_aux_general[OF _ d], auto)

text‹This is the soundess lemma.›

lemma Smith_normal_form_diagonal_to_Smith:
  fixes A::"'a::{bezout_ring}^'b::mod_type^'c::mod_type"
  assumes ib: "is_bezout_ext bezout"
  and d: "isDiagonal A"
  shows "Smith_normal_form (diagonal_to_Smith A bezout)"
proof -
  let ?k = "min (nrows A) (ncols A) - 2"
  let ?Dk = "(diagonal_to_Smith_aux A [0..<?k] bezout)"
  have min_eq: "min (nrows A) (ncols A) - 1 = Suc ?k" 
    by (metis Suc_1 Suc_diff_Suc min_less_iff_conj ncols_def nrows_def to_nat_1 to_nat_less_card)
  have set_rw: "[0..<min (nrows A) (ncols A) - 1] = [0..<?k] @ [?k]" 
    unfolding min_eq by auto    
  have d2: "isDiagonal (diagonal_to_Smith A bezout)" 
    by (rule isDiagonal_diagonal_to_Smith[OF d])
  have smith_Suc_k: "Smith_normal_form_upt_k (diagonal_to_Smith A bezout) (Suc ?k)" 
  proof (rule Smith_normal_form_upt_k1_intro_diagonal[OF _ d2])
    have "diagonal_to_Smith A bezout = diagonal_to_Smith_aux A [0..<min (nrows A) (ncols A) - 1] bezout" 
      unfolding diagonal_to_Smith_def by auto
    also have "... = Diagonal_to_Smith_row_i ?Dk ?k bezout" 
      unfolding set_rw
      unfolding diagonal_to_Smith_aux_append2 by auto
    finally have d_rw: "diagonal_to_Smith A bezout = Diagonal_to_Smith_row_i ?Dk ?k bezout" .
    have "Smith_normal_form_upt_k ?Dk ?k" 
      by (rule Smith_normal_form_upt_k_diagonal_to_Smith_aux[OF ib _ d], insert min_eq, linarith)
    thus "Smith_normal_form_upt_k (diagonal_to_Smith A bezout) ?k" unfolding d_rw 
      by (metis Smith_normal_form_upt_k_Suc_eq Suc_1 ib d_rw diagonal_to_Smith_def diff_0_eq_0 
          diff_less min_eq not_gr_zero zero_less_Suc)        
    show "diagonal_to_Smith A bezout $ from_nat (?k - 1) $ from_nat (?k - 1) dvd
          diagonal_to_Smith A bezout $ from_nat ?k $ from_nat ?k"
    proof (unfold diagonal_to_Smith_def, rule diagonal_to_Smith_aux_dvd[OF ib])
      show "?k - 1 < min (nrows A) (ncols A) - 1"
        using min_eq by linarith
      show "min (nrows A) (ncols A) - 1 < min (nrows A) (ncols A)" using min_eq by linarith
      thus "to_nat (from_nat ?k::'c) = to_nat (from_nat ?k::'b)"
        by (metis (mono_tags, lifting) Suc_lessD min_eq min_less_iff_conj 
            ncols_def nrows_def to_nat_from_nat_id)
      show "?k - 1  to_nat (from_nat ?k::'c)"         
        by (metis (no_types, lifting) diff_le_self from_nat_not_eq lessI less_le_trans 
            min.cobounded1 min_eq nrows_def)     
    qed
  qed
  have s_eq: "Smith_normal_form (diagonal_to_Smith A bezout) 
     = Smith_normal_form_upt_k (diagonal_to_Smith A bezout) 
    (Suc (min (nrows (diagonal_to_Smith A bezout)) (ncols (diagonal_to_Smith A bezout)) - 1))"
    unfolding Smith_normal_form_min by (simp add: ncols_def nrows_def)
  let ?min1="(min (nrows (diagonal_to_Smith A bezout)) (ncols (diagonal_to_Smith A bezout)) - 1)"
  show ?thesis unfolding s_eq
  proof (rule Smith_normal_form_upt_k1_intro_diagonal[OF _ d2])
    show "Smith_normal_form_upt_k (diagonal_to_Smith A bezout) ?min1"
      using smith_Suc_k min_eq by auto   
    have "diagonal_to_Smith A bezout $ from_nat ?k $ from_nat ?k 
      dvd diagonal_to_Smith A bezout $ from_nat (?k + 1) $ from_nat (?k + 1)"
      by (smt One_nat_def Suc_eq_plus1 ib Suc_pred diagonal_to_Smith_aux_dvd diagonal_to_Smith_def 
          le_add1 lessI min_eq min_less_iff_conj ncols_def nrows_def to_nat_from_nat_id zero_less_card_finite)
    thus "diagonal_to_Smith A bezout $ from_nat (?min1 - 1) $ from_nat (?min1 - 1) 
      dvd diagonal_to_Smith A bezout $ from_nat ?min1 $ from_nat ?min1" 
      using min_eq by auto
  qed
qed

subsection‹Implementation and formal proof 
  of the matrices $P$ and $Q$ which transform the input matrix by means of elementary operations.›


fun diagonal_step_PQ :: "'a::{bezout_ring}^'cols::mod_type^'rows::mod_type  nat  nat  'a bezout  
(
('a::{bezout_ring}^'rows::mod_type^'rows::mod_type) ×
('a::{bezout_ring}^'cols::mod_type^'cols::mod_type)
)"
  where "diagonal_step_PQ A i k bezout = 
  (let  i_row = from_nat i; k_row = from_nat k; i_col = from_nat i; k_col = from_nat k;
        (p, q, u, v, d) = bezout (A $ i_row $ from_nat i) (A $ k_row $ from_nat k);
        P = row_add (interchange_rows (row_add (mat 1) k_row i_row p) i_row k_row) k_row i_row (-v);
        Q = mult_column (column_add (column_add (mat 1) i_col k_col q) k_col i_col u) k_col (-1)
        in (P,Q)
        )"

text‹Examples›

value "let A = list_of_list_to_matrix [[12,0,0::int],[0,6,0::int],[0,0,2::int]]::int^3^3;
            i=0; k=1;
           (p, q, u, v, d) = euclid_ext2 (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k);
            (P,Q) = diagonal_step_PQ A i k euclid_ext2
  in matrix_to_list_of_list (diagonal_step A i k d v)"

value "let A = list_of_list_to_matrix [[12,0,0::int],[0,6,0::int],[0,0,2::int]]::int^3^3;
            i=0; k=1;
           (p, q, u, v, d) = euclid_ext2 (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k);
            (P,Q) = diagonal_step_PQ A i k euclid_ext2
  in matrix_to_list_of_list (P**(A)**Q)"


value "let A = list_of_list_to_matrix [[12,0,0::int],[0,6,0::int],[0,0,2::int]]::int^3^3;
            i=0; k=1;
           (p, q, u, v, d) = euclid_ext2 (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k);
            (P,Q) = diagonal_step_PQ A i k euclid_ext2
  in matrix_to_list_of_list (P**(A)**Q)"


lemmas diagonal_step_PQ_def = diagonal_step_PQ.simps

lemma from_nat_neq_rows:
  fixes A::"'a^'cols::mod_type^'rows::mod_type"
  assumes i: "i<(nrows A)" and k: "k<(nrows A)" and ik: "i  k"
  shows "from_nat i  (from_nat k::'rows)"
proof (rule ccontr, auto)
  let ?i="from_nat i::'rows"
  let ?k="from_nat k::'rows"
  assume "?i = ?k"
  hence "to_nat ?i = to_nat ?k" by auto
  hence "i = k" 
    unfolding to_nat_from_nat_id[OF i[unfolded nrows_def]] 
    unfolding to_nat_from_nat_id[OF k[unfolded nrows_def]] .
  thus False using ik by contradiction
qed


lemma from_nat_neq_cols:
  fixes A::"'a^'cols::mod_type^'rows::mod_type"
  assumes i: "i<(ncols A)" and k: "k<(ncols A)" and ik: "i  k"
  shows "from_nat i  (from_nat k::'cols)"
proof (rule ccontr, auto)
  let ?i="from_nat i::'cols"
  let ?k="from_nat k::'cols"
  assume "?i = ?k"
  hence "to_nat ?i = to_nat ?k" by auto
  hence "i = k" 
    unfolding to_nat_from_nat_id[OF i[unfolded ncols_def]] 
    unfolding to_nat_from_nat_id[OF k[unfolded ncols_def]] .
  thus False using ik by contradiction
qed



lemma diagonal_step_PQ_invertible_P:
  fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
  assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout"
  and pquvd: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)"
  and i_not_k: "i  k" 
  and i: "i<min (nrows A) (ncols A)" and k: "k<min (nrows A) (ncols A)"
shows "invertible P"
proof -
  let ?step1 = "(row_add (mat 1) (from_nat k::'rows) (from_nat i) p)"
  let ?step2 = "interchange_rows ?step1 (from_nat i) (from_nat k)"
  let ?step3 = "row_add (?step2) (from_nat k) (from_nat i) (- v)"
  have p: "p = fst (bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k))"
    using pquvd by (metis fst_conv)
  have v: "-v = (- fst (snd (snd (snd (bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k))))))"
    using pquvd by (metis fst_conv snd_conv)
  have i_not_k2: "from_nat k  (from_nat i::'rows)" 
    by (rule from_nat_neq_rows, insert i k i_not_k, auto)
  have "invertible ?step3" 
  unfolding row_add_mat_1[of _ _ _ ?step2, symmetric] 
  proof (rule invertible_mult)
    show "invertible (row_add (mat 1) (from_nat k::'rows) (from_nat i) (- v))"
      by (rule invertible_row_add[OF i_not_k2])          
    show "invertible ?step2"      
      by (metis i_not_k2 interchange_rows_mat_1 invertible_interchange_rows
          invertible_mult invertible_row_add)
  qed
  thus ?thesis
    using PQ p v unfolding diagonal_step_PQ_def Let_def split_beta 
    by auto
qed



lemma diagonal_step_PQ_invertible_Q:
  fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
  assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout"
  and pquvd: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)"
  and i_not_k: "i  k" 
  and i: "i<min (nrows A) (ncols A)" and k: "k<min (nrows A) (ncols A)"
shows "invertible Q"
proof -
  let ?step1 = "column_add (mat 1) (from_nat i::'cols) (from_nat k) q"
  let ?step2 = "column_add ?step1 (from_nat k) (from_nat i) u"
  let ?step3 = "mult_column ?step2 (from_nat k) (- 1)"
  have u: "u = (fst (snd (snd (bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)))))"
    by (metis fst_conv pquvd snd_conv)
  have q: "q = (fst (snd (bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k))))"
    by (metis fst_conv pquvd snd_conv)
  have "invertible ?step3"
    unfolding column_add_mat_1[of _ _ _ ?step2, symmetric] 
    unfolding mult_column_mat_1[of  ?step2, symmetric]
  proof (rule invertible_mult)
    show "invertible (mult_column (mat 1) (from_nat k::'cols) (- 1::'a))"
      by (rule invertible_mult_column[of _ "-1"], auto)
    show "invertible ?step2"
      by (metis column_add_mat_1 i i_not_k invertible_column_add invertible_mult k 
          min_less_iff_conj ncols_def to_nat_from_nat_id)
  qed
  thus ?thesis 
    using PQ pquvd u q unfolding diagonal_step_PQ_def
    by (auto simp add: Let_def split_beta)
qed

lemma mat_q_1[simp]: "mat q $ a $ a = q" unfolding mat_def by auto

lemma mat_q_0[simp]:
  assumes ab: "a  b" 
  shows "mat q $ a $ b = 0" using ab unfolding mat_def by auto

text‹This is an alternative definition for the matrix P in each step, where entries are 
  given explicitly instead of being computed as a composition of elementary operations. ›

lemma diagonal_step_PQ_P_alt:
fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
  assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout"
  and pquvd: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)"
  and i: "i<min (nrows A) (ncols A)" and k: "k<min (nrows A) (ncols A)" and ik: "i  k"
shows "
  P = (χ a b. 
  if a = from_nat i  b = from_nat i then p else 
  if a = from_nat i  b = from_nat k then 1 else
  if a = from_nat k  b = from_nat i then -v * p + 1 else
  if a = from_nat k  b = from_nat k then -v else
  if a = b then 1 else 0)"
proof -  
  have ik1: "from_nat i  (from_nat k::'rows)"
    using from_nat_neq_rows i ik k by auto
  have "P $ a $ b =
              (if a = from_nat i  b = from_nat i then p
               else if a = from_nat i  b = from_nat k then 1
                    else if a = from_nat k  b = from_nat i then - v * p + 1
                         else if a = from_nat k  b = from_nat k then - v else if a = b then 1 else 0)" 
    for a b
      using PQ ik1  pquvd  
      unfolding diagonal_step_PQ_def 
      unfolding row_add_def interchange_rows_def
      by (auto simp add: Let_def split_beta)
         (metis (mono_tags, hide_lams) fst_conv snd_conv)+
    thus ?thesis unfolding vec_eq_iff unfolding vec_lambda_beta by auto
qed


text‹This is an alternative definition for the matrix Q in each step, where entries are
  given explicitly instead of being computed as a composition of elementary operations.›

lemma diagonal_step_PQ_Q_alt:
fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
  assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout"
  and pquvd: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)"
  and i: "i<min (nrows A) (ncols A)" and k: "k<min (nrows A) (ncols A)" and ik: "i  k"
shows "
  Q = (χ a b. 
  if a = from_nat i  b = from_nat i then 1 else 
  if a = from_nat i  b = from_nat k then -u else
  if a = from_nat k  b = from_nat i then q else
  if a = from_nat k  b = from_nat k then -q*u-1 else
  if a = b then 1 else 0)"
proof -
  have ik1: "from_nat i  (from_nat k::'cols)"
    using from_nat_neq_cols i ik k by auto
  have "Q $ a $ b =
  (if a = from_nat i  b = from_nat i then 1 else 
  if a = from_nat i  b = from_nat k then -u else
  if a = from_nat k  b = from_nat i then q else
  if a = from_nat k  b = from_nat k then -q*u-1 else
  if a = b then 1 else 0)"  for a b
  using PQ ik1 pquvd unfolding diagonal_step_PQ_def
  unfolding column_add_def mult_column_def
  by (auto simp add: Let_def split_beta)
     (metis (mono_tags, hide_lams) fst_conv snd_conv)+
  thus ?thesis unfolding vec_eq_iff unfolding vec_lambda_beta by auto
qed
  
text‹P**A can be rewriten as elementary operations over A.›

lemma diagonal_step_PQ_PA:
  fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
  assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout"
    and b: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)"
shows "P**A = row_add (interchange_rows 
  (row_add A (from_nat k) (from_nat i) p) (from_nat i) (from_nat k)) (from_nat k) (from_nat i) (- v)" 
proof -
  let ?i_row = "from_nat i::'rows" and ?k_row = "from_nat k::'rows"
  let ?P1 = "row_add (mat 1) ?k_row ?i_row p"
  let ?P2' = "interchange_rows ?P1 ?i_row ?k_row"
  let ?P2 = "interchange_rows (mat 1) (from_nat i) (from_nat k)"
  let ?P3 = "row_add (mat 1) (from_nat k) (from_nat i) (- v)"
  have "P = row_add ?P2' ?k_row ?i_row (- v)"
    using PQ b unfolding diagonal_step_PQ_def 
    by (auto simp add: Let_def split_beta, metis fstI sndI)
  also have "... = ?P3 ** ?P2'" 
    unfolding row_add_mat_1[of _ _ _ ?P2', symmetric] by auto
  also have "... = ?P3 ** (?P2 ** ?P1)" 
    unfolding interchange_rows_mat_1[of _ _ ?P1, symmetric] by auto  
  also have "... ** A = row_add (interchange_rows 
  (row_add A (from_nat k) (from_nat i) p) (from_nat i) (from_nat k)) (from_nat k) (from_nat i) (- v)"
    by (metis interchange_rows_mat_1 matrix_mul_assoc row_add_mat_1)
  finally show ?thesis .
qed


lemma diagonal_step_PQ_PAQ':
  fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
  assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout"
    and b: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)"
  shows "P**A**Q = (mult_column (column_add (column_add (P**A) (from_nat i) (from_nat k) q) 
                   (from_nat k) (from_nat i) u) (from_nat k) (- 1))" 
proof -
  let ?i_col = "from_nat i::'cols" and ?k_col = "from_nat k::'cols"
  let ?Q1="(column_add (mat 1) ?i_col ?k_col q)"
  let ?Q2' = "(column_add ?Q1 ?k_col ?i_col u)"
  let ?Q2 = "column_add (mat 1) (from_nat k) (from_nat i) u"
  let ?Q3 = "mult_column (mat 1) (from_nat k) (- 1)"
  have "Q = mult_column ?Q2' ?k_col (-1)"
    using PQ b unfolding diagonal_step_PQ_def 
    by (auto simp add: Let_def split_beta, metis fstI sndI)
  also have "... = ?Q2' ** ?Q3" 
    unfolding mult_column_mat_1[of ?Q2', symmetric] by auto
  also have "... = (?Q1**?Q2)**?Q3" 
    unfolding column_add_mat_1[of ?Q1, symmetric] by auto
  also have " (P**A) **  ((?Q1**?Q2)**?Q3) = 
    (mult_column (column_add (column_add (P**A) ?i_col ?k_col q) ?k_col ?i_col u) ?k_col (- 1))"
    by (metis (no_types, lifting) column_add_mat_1 matrix_mul_assoc mult_column_mat_1)
  finally show ?thesis .
qed

corollary diagonal_step_PQ_PAQ:
  fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
  assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout"
    and b: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)"
  shows "P**A**Q = (mult_column (column_add (column_add (row_add (interchange_rows 
                    (row_add A (from_nat k) (from_nat i) p) (from_nat i) 
                    (from_nat k)) (from_nat k) (from_nat i) (- v)) (from_nat i) (from_nat k) q) 
                   (from_nat k) (from_nat i) u) (from_nat k) (- 1))"
  using diagonal_step_PQ_PA diagonal_step_PQ_PAQ' assms by metis

lemma isDiagonal_imp_0: 
  assumes "isDiagonal A"
  and "from_nat a  from_nat b"
  and "a < min (nrows A) (ncols A)"
  and "b < min (nrows A) (ncols A)"
  shows "A $ from_nat a $ from_nat b = 0" 
  by (metis assms isDiagonal min.strict_boundedE ncols_def nrows_def to_nat_from_nat_id)



lemma diagonal_step_PQ:
  fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type"
  assumes PQ: "(P,Q) = diagonal_step_PQ A i k bezout"
    and b: "(p,q,u,v,d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat k $ from_nat k)"
  and i: "i<min (nrows A) (ncols A)" and k: "k<min (nrows A) (ncols A)" and ik: "i  k"
  and ib: "is_bezout_ext bezout" and diag: "isDiagonal A"
  shows "diagonal_step A i k d v = P**A**Q"
proof -
  let ?i_row = "from_nat i::'rows" 
    and ?k_row = "from_nat k::'rows" and ?i_col = "from_nat i::'cols" and ?k_col = "from_nat k::'cols"
  let ?P1 = "(row_add (mat 1) ?k_row ?i_row p)"
  let ?Aii = "A $ ?i_row $ ?i_col"
  let ?Akk = "A $ ?k_row $ ?k_col"
  have k1: "k<ncols A" and k2: "k<nrows A" and i1: "i<nrows A" and i2: "i<ncols A" using i k by auto
  have Aik0: "A $ ?i_row $ ?k_col = 0"
    by (metis diag i ik isDiagonal k min.strict_boundedE ncols_def nrows_def to_nat_from_nat_id)
  have Aki0: "A $ ?k_row $ ?i_col = 0"
    by (metis diag i ik isDiagonal k min.strict_boundedE ncols_def nrows_def to_nat_from_nat_id)
  have du: "d * u = - A $ ?k_row $ ?k_col"
    using b ib unfolding is_bezout_ext_def 
    by (auto simp add: split_beta) (metis fst_conv snd_conv)
  have dv: "d * v = A $ ?i_row $ ?i_col"
    using b ib unfolding is_bezout_ext_def 
    by (auto simp add: split_beta) (metis fst_conv snd_conv)
  have d: "d = p * ?Aii + ?Akk * q" 
    using b ib unfolding is_bezout_ext_def 
    by (auto simp add: split_beta) (metis fst_conv mult.commute snd_conv)
  have "(?Aii - v * (p * ?Aii) - v * ?Akk * q) * u = (?Aii - v * ((p * ?Aii) + ?Akk * q)) * u"
      by (simp add: diff_diff_add distrib_left mult.assoc)
    also have "... = (?Aii*u - d* v *u)"
      by (simp add: mult.commute right_diff_distrib d)
    also have "... = 0" by (simp add: dv)
    finally have rw: "(?Aii - v * (p * ?Aii) - v * ?Akk * q) * u = 0" .
    have a1: "from_nat k  (from_nat i::'rows)"
      using from_nat_neq_rows i ik k by auto
    have a2: "from_nat k  (from_nat i::'cols)"
      using from_nat_neq_cols i ik k by auto
    have Aab0: "A $ a $ from_nat b = 0" if ab: "a  from_nat b" and b_ncols: "b < ncols A" for a b
      by (metis ab b_ncols diag from_nat_to_nat_id isDiagonal ncols_def to_nat_from_nat_id)  
    have Aab0': "A $ from_nat a $ b = 0" if ab: "from_nat a  b" and a_nrows: "a < nrows A" for a b
      by (metis ab a_nrows diag from_nat_to_nat_id isDiagonal nrows_def to_nat_from_nat_id)
  show ?thesis
  proof (unfold diagonal_step_def vec_eq_iff, auto)
    show "d = (P ** A ** Q) $ from_nat i $ from_nat i"
      and "d = (P ** A ** Q) $ from_nat i $ from_nat i"
      and "d = (P ** A ** Q) $ from_nat i $ from_nat i"
    unfolding diagonal_step_PQ_PAQ[OF PQ b] 
    unfolding mult_column_def column_add_def interchange_rows_def row_add_def 
      unfolding vec_lambda_beta using a1 a2
      using Aik0 Aki0 d by auto
    show "v * A $ from_nat k $ from_nat k = (P ** A ** Q) $ from_nat k $ from_nat k"
      and "v * A $ from_nat k $ from_nat k = (P ** A ** Q) $ from_nat k $ from_nat k"
      using a1 a2  
      unfolding diagonal_step_PQ_PAQ[OF PQ b] mult_column_def column_add_def 
      unfolding interchange_rows_def row_add_def 
      unfolding vec_lambda_beta unfolding Aik0 Aki0 by (auto simp add: rw)
    fix a::'rows and b::'cols 
    assume ak: "a  from_nat k" and ai: "a  from_nat i" 
    show "A $ a $ b = (P ** A ** Q) $ a $ b"
      using ai ak a1 a2 Aab0 k1 i2
      unfolding diagonal_step_PQ_PAQ[OF PQ b] 
      unfolding mult_column_def column_add_def interchange_rows_def row_add_def 
      unfolding vec_lambda_beta by auto
  next
    fix a::'rows and b::'cols 
    assume ak: "a  from_nat k" and ai: "b  from_nat i" 
    show "A $ a $ b = (P ** A ** Q) $ a $ b"
      using ai ak a1 a2 Aab0 Aab0' d du k1 k2 i1 i2
      unfolding diagonal_step_PQ_PAQ[OF PQ b] 
      unfolding mult_column_def column_add_def interchange_rows_def row_add_def 
      unfolding vec_lambda_beta by auto
  next
    fix a::'rows and b::'cols 
    assume ak: "b  from_nat k" and ai: "a  from_nat i" 
    show "A $ a $ b = (P ** A ** Q) $ a $ b"
      using ai ak a1 a2 Aab0 Aab0' d du k1 k2 i1 i2
      unfolding diagonal_step_PQ_PAQ[OF PQ b] 
      unfolding mult_column_def column_add_def interchange_rows_def row_add_def 
      unfolding vec_lambda_beta apply auto (*TODO: cleanup this sledeghammer proof*)
      proof -
        assume "d = p * ?Aii+ ?Akk* q"
        then have "v * (p * ?Aii) + v * (?Akk* q) = d * v"
          by (simp add: ring_class.ring_distribs(1) semiring_normalization_rules(7))
        then have "?Aii- v * (p * ?Aii) - v * (?Akk* q) = 0"
          by (simp add: diff_diff_add dv)
        then show "?Aii- v * (p * ?Aii) = v * ?Akk* q"
          by force
      qed
    next
    fix a::'rows and b::'cols 
    assume ak: "b  from_nat k" and ai: "b  from_nat i" 
    show "A $ a $ b = (P ** A ** Q) $ a $ b"
      using ai ak a1 a2 Aab0 Aab0' d du k1 k2 i1 i2
      unfolding diagonal_step_PQ_PAQ[OF PQ b] 
      unfolding mult_column_def column_add_def interchange_rows_def row_add_def 
      unfolding vec_lambda_beta by auto
  qed
qed



fun diagonal_to_Smith_i_PQ :: 
"nat list  nat  ('a::{bezout_ring} bezout) 
   (('a^'rows::mod_type^'rows::mod_type)×('a^'cols::mod_type^'rows::mod_type)× ('a^'cols::mod_type^'cols::mod_type))
   (('a^'rows::mod_type^'rows::mod_type)× ('a^'cols::mod_type^'rows::mod_type) × ('a^'cols::mod_type^'cols::mod_type))"
 where
"diagonal_to_Smith_i_PQ [] i bezout (P,A,Q) = (P,A,Q)" |
"diagonal_to_Smith_i_PQ (j#xs) i bezout (P,A,Q) = (
  if A $ (from_nat i) $ (from_nat i) dvd A $ (from_nat j) $ (from_nat j) 
     then diagonal_to_Smith_i_PQ xs i bezout (P,A,Q)
  else let (p, q, u, v, d) = bezout (A $ from_nat i $ from_nat i) (A $ from_nat j $ from_nat j); 
           A' = diagonal_step A i j d v;
          (P',Q') = diagonal_step_PQ A i j bezout
      in diagonal_to_Smith_i_PQ xs i bezout (P'**P,A',Q**Q') ― ‹Apply the step›
  )
  "


text‹This is implemented by fun. This way, I can do pattern-matching for $(P,A,Q)$.›

fun Diagonal_to_Smith_row_i_PQ
  where "Diagonal_to_Smith_row_i_PQ i bezout (P,A,Q) 
  = diagonal_to_Smith_i_PQ [i + 1..<min (nrows A) (ncols A)] i bezout (P,A,Q)"


text‹Deleted from the simplified and renamed as it would be a definition.›

declare Diagonal_to_Smith_row_i_PQ.simps[simp del]
lemmas Diagonal_to_Smith_row_i_PQ_def = Diagonal_to_Smith_row_i_PQ.simps

fun diagonal_to_Smith_aux_PQ 
  where
  "diagonal_to_Smith_aux_PQ [] bezout (P,A,Q) = (P,A,Q)" |
  "diagonal_to_Smith_aux_PQ (i#xs) bezout (P,A,Q) 
      = diagonal_to_Smith_aux_PQ xs bezout (Diagonal_to_Smith_row_i_PQ i bezout (P,A,Q))"


lemma diagonal_to_Smith_aux_PQ_append:
  "diagonal_to_Smith_aux_PQ (xs @ ys) bezout (P,A,Q)
    = diagonal_to_Smith_aux_PQ ys bezout (diagonal_to_Smith_aux_PQ xs bezout (P,A,Q))"
  by (induct xs bezout "(P,A,Q)" arbitrary: P A Q rule: diagonal_to_Smith_aux_PQ.induct)
     (auto, metis prod_cases3)


lemma diagonal_to_Smith_aux_PQ_append2[simp]:
  "diagonal_to_Smith_aux_PQ (xs @ [ys]) bezout (P,A,Q) 
    = Diagonal_to_Smith_row_i_PQ ys bezout (diagonal_to_Smith_aux_PQ xs bezout (P,A,Q))"
proof (induct xs bezout "(P,A,Q)" arbitrary: P A Q rule: diagonal_to_Smith_aux_PQ.induct)
  case (1 bezout P A Q)
  then show ?case 
    by (metis append.simps(1) diagonal_to_Smith_aux_PQ.simps prod.exhaust)
next
  case (2 i xs bezout P A Q)
  then show ?case
    by (metis (no_types, hide_lams) append_Cons diagonal_to_Smith_aux_PQ.simps(2) prod_cases3)
qed 

(*
definition "diagonal_to_Smith_PQ A bezout 
  = diagonal_to_Smith_aux_PQ [0..<min (nrows A) (ncols A) - 1] bezout (mat 1, A, mat 1)"
*)

context
  fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" (*This is the input matrix*)
  and B::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" (*This is the matrix in each step*)
  and P and Q
  and bezout::"'a bezout"
  assumes PAQ: "P**A**Q = B"
  and P: "invertible P" and Q: "invertible Q"
  and ib: "is_bezout_ext bezout"
begin

text‹The output is the same as the one in the version where $P$ and $Q$ are not computed.›

lemma diagonal_to_Smith_i_PQ_eq:
  assumes P'B'Q': "(P',B',Q') = diagonal_to_Smith_i_PQ xs i bezout (P,B,Q)"
  and xs: "x. x  set xs  x < min (nrows A) (ncols A)" 
  and diag: "isDiagonal B" and i_notin: "i  set xs" and i: "i<min (nrows A) (ncols A)"
shows "B' = diagonal_to_Smith_i xs B i bezout"     
  using assms PAQ ib P Q 
proof (induct xs i bezout "(P,B,Q)" arbitrary: P B Q rule:diagonal_to_Smith_i_PQ.induct)
  case (1 i bezout P A Q)
  then show ?case by auto
next
  case (2 j xs i bezout P B Q)
  let ?Bii = "B $ from_nat i $ from_nat i"
  let ?Bjj = "B $ from_nat j $ from_nat j"
  let ?p="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d)  p"  
  let ?q="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d)  q"
  let ?u="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d)  u"
  let ?v="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d)  v"
  let ?d="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d)  d"
  let ?B'="diagonal_step B i j ?d ?v" 
  let ?P' = "fst (diagonal_step_PQ B i j bezout)"
  let ?Q' = "snd (diagonal_step_PQ B i j bezout)"
  have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j)"
    by (simp add: split_beta)
  note hyp = "2.hyps"(2)
    note P'B'Q' = "2.prems"(1)
    note i_min = "2.prems"(5)
    note PAQ_B = "2.prems"(6)
    note i_notin = "2.prems"(4)
    note diagB = "2.prems"(3)    
    note xs_min = "2.prems"(2)      
    note ib = "2.prems"(7)
    note inv_P = "2.prems"(8)
    note inv_Q = "2.prems"(9)
  show ?case
  proof (cases "?Bii dvd ?Bjj")
    case True    
    show ?thesis using "2.prems" "2.hyps"(1) True by auto
  next
    case False    
    have aux: "diagonal_to_Smith_i_PQ (j # xs) i bezout (P, B, Q) 
      = diagonal_to_Smith_i_PQ xs i bezout (?P'**P,?B', Q**?Q')"
      using False by (auto simp add: split_beta)
    have i: "i < min (nrows B) (ncols B)" using i_min unfolding nrows_def ncols_def by auto
    have j: "j < min (nrows B) (ncols B)" using xs_min unfolding nrows_def ncols_def by auto     
    have aux2: "diagonal_to_Smith_i(j # xs) B i bezout = diagonal_to_Smith_i xs ?B' i bezout"
      using False by (auto simp add: split_beta)
    have res: " B' = diagonal_to_Smith_i xs ?B' i bezout"
    proof (rule hyp[OF False])
      show "(P', B', Q') = diagonal_to_Smith_i_PQ xs i bezout (?P'**P,?B', Q**?Q')" 
        using aux P'B'Q' by auto
      have B'_P'B'Q': "?B' = ?P'**B**?Q'"
        by (rule diagonal_step_PQ[OF _ _ i j _ ib diagB], insert i_notin pquvd, auto)
      show "?P'**P ** A ** (Q**?Q') = ?B'"
        unfolding B'_P'B'Q' unfolding PAQ_B[symmetric]
        by (simp add: matrix_mul_assoc)       
      show "isDiagonal ?B'" by (rule isDiagonal_diagonal_step[OF diagB i j])
      show "invertible (?P'** P)"
        by (metis inv_P diagonal_step_PQ_invertible_P i i_notin in_set_member 
           invertible_mult j member_rec(1) prod.exhaust_sel)
      show "invertible (Q ** ?Q')"
        by (metis diagonal_step_PQ_invertible_Q i i_notin inv_Q 
            invertible_mult j list.set_intros(1) prod.collapse)
    qed (insert pquvd xs_min i_min i_notin ib, auto)
    show ?thesis using aux aux2 res by auto
  qed
qed


lemma diagonal_to_Smith_i_PQ':
  assumes P'B'Q': "(P',B',Q') = diagonal_to_Smith_i_PQ xs i bezout (P,B,Q)"
  and xs: "x. x  set xs  x < min (nrows A) (ncols A)" 
  and diag: "isDiagonal B" and i_notin: "i  set xs" and i: "i<min (nrows A) (ncols A)"
shows "B' = P'**A**Q'  invertible P'  invertible Q'"
  using assms PAQ ib P Q
proof (induct xs i bezout "(P,B,Q)" arbitrary: P B Q rule:diagonal_to_Smith_i_PQ.induct)
  case (1 i bezout)
  then show ?case using PAQ by auto
next
  case (2 j xs i bezout P B Q)
  let ?Bii = "B $ from_nat i $ from_nat i"
  let ?Bjj = "B $ from_nat j $ from_nat j"
  let ?p="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d)  p"  
  let ?q="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d)  q"
  let ?u="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d)  u"
  let ?v="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d)  v"
  let ?d="case bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j) of (p,q,u,v,d)  d"
  let ?B'="diagonal_step B i j ?d ?v" 
  let ?P' = "fst (diagonal_step_PQ B i j bezout)"
  let ?Q' = "snd (diagonal_step_PQ B i j bezout)"
  have pquvd: "(?p, ?q, ?u, ?v,?d) = bezout (B $ from_nat i $ from_nat i) (B $ from_nat j $ from_nat j)"
    by (simp add: split_beta)
  show ?case
  proof (cases "?Bii dvd ?Bjj")
    case True    
    then show ?thesis using "2.prems"
      using "2.hyps"(1) by auto
  next
    case False
    note hyp = "2.hyps"(2)
    note P'B'Q' = "2.prems"(1)
    note i_min = "2.prems"(5)
    note PAQ_B = "2.prems"(6)
    note i_notin = "2.prems"(4)
    note diagB = "2.prems"(3)    
    note xs_min = "2.prems"(2)      
    note ib = "2.prems"(7)
    note inv_P = "2.prems"(8)
    note inv_Q = "2.prems"(9)
    have aux: "diagonal_to_Smith_i_PQ (j # xs) i bezout (P, B, Q) 
      = diagonal_to_Smith_i_PQ xs i bezout (?P'**P,?B', Q**?Q')"
      using False by (auto simp add: split_beta)
    have i: "i < min (nrows B) (ncols B)" using i_min unfolding nrows_def ncols_def by auto
    have j: "j < min (nrows B) (ncols B)" using xs_min unfolding nrows_def ncols_def by auto     
    show ?thesis
    proof (rule hyp[OF False])
      show "(P', B', Q') = diagonal_to_Smith_i_PQ xs i bezout (?P'**P,?B', Q**?Q')" 
        using aux P'B'Q' by auto
      have B'_P'B'Q': "?B' = ?P'**B**?Q'"
        by (rule diagonal_step_PQ[OF _ _ i j _ ib diagB], insert i_notin pquvd, auto)
      show "?P'**P ** A ** (Q**?Q') = ?B'"
        unfolding B'_P'B'Q' unfolding PAQ_B[symmetric]
        by (simp add: matrix_mul_assoc)       
      show "isDiagonal ?B'" by (rule isDiagonal_diagonal_step[OF diagB i j])
      show "invertible (?P'** P)"
        by (metis inv_P diagonal_step_PQ_invertible_P i i_notin in_set_member 
           invertible_mult j member_rec(1) prod.exhaust_sel)
      show "invertible (Q ** ?Q')"
        by (metis diagonal_step_PQ_invertible_Q i i_notin inv_Q 
            invertible_mult j list.set_intros(1) prod.collapse)
    qed (insert pquvd xs_min i_min i_notin ib, auto)    
  qed
qed


corollary diagonal_to_Smith_i_PQ:
  assumes P'B'Q': "(P',B',Q') = diagonal_to_Smith_i_PQ xs i bezout (P,B,Q)"
  and xs: "x. x  set xs  x < min (nrows A) (ncols A)" 
  and diag: "isDiagonal B" and i_notin: "i  set xs" and i: "i<min (nrows A) (ncols A)"
shows "B' = P'**A**Q'  invertible P'  invertible Q'  B' = diagonal_to_Smith_i xs B i bezout"
  using assms diagonal_to_Smith_i_PQ' diagonal_to_Smith_i_PQ_eq by metis

lemma Diagonal_to_Smith_row_i_PQ_eq:
  assumes P'B'Q': "(P',B',Q') = Diagonal_to_Smith_row_i_PQ i bezout (P,B,Q)"
    and diag: "isDiagonal B" and i: "i < min (nrows A) (ncols A)"
  shows "B' = Diagonal_to_Smith_row_i B i bezout"
  using assms unfolding Diagonal_to_Smith_row_i_def Diagonal_to_Smith_row_i_PQ_def
  using diagonal_to_Smith_i_PQ by (auto simp add: nrows_def ncols_def)

lemma Diagonal_to_Smith_row_i_PQ':
  assumes P'B'Q': "(P',B',Q') = Diagonal_to_Smith_row_i_PQ i bezout (P,B,Q)"
    and diag: "isDiagonal B" and i: "i < min (nrows A) (ncols A)"
  shows "B' = P'**A**Q'  invertible P'  invertible Q'"
  by (rule diagonal_to_Smith_i_PQ'[OF P'B'Q'[unfolded Diagonal_to_Smith_row_i_PQ_def] _ diag _ i],
     auto simp add: nrows_def ncols_def)

lemma Diagonal_to_Smith_row_i_PQ:
  assumes P'B'Q': "(P',B',Q') = Diagonal_to_Smith_row_i_PQ i bezout (P,B,Q)"
    and diag: "isDiagonal B" and i: "i < min (nrows A) (ncols A)"
  shows "B' = P'**A**Q'  invertible P'  invertible Q'  B' = Diagonal_to_Smith_row_i B i bezout"
  using assms Diagonal_to_Smith_row_i_PQ' Diagonal_to_Smith_row_i_PQ_eq by presburger

end

context
  fixes A::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" (*This is the input matrix*)
  and B::"'a::{bezout_ring}^'cols::mod_type^'rows::mod_type" (*This is the matrix in each step*)
  and P and Q
  and bezout::"'a bezout"
  assumes PAQ: "P**A**Q = B"
  and P: "invertible P" and Q: "invertible Q"
  and ib: "is_bezout_ext bezout"
begin


lemma diagonal_to_Smith_aux_PQ:
  assumes P'B'Q': "(P',B',Q') = diagonal_to_Smith_aux_PQ [0..<k] bezout (P,B,Q)"
  and diag: "isDiagonal B" and k:"k<min (nrows A) (ncols A)"
shows "B' = P'**A**Q'  invertible P'  invertible Q'  B' = diagonal_to_Smith_aux B [0..<k] bezout"
  using k P'B'Q' P Q PAQ diag
proof (induct k arbitrary: P B Q P' Q' B')
  case 0
  then show ?case using P Q PAQ by auto
next
  case (Suc k P B Q P' Q' B')
  note Suc_k = Suc.prems(1)
  note PBQ = Suc.prems(2)
  note P = Suc.prems(3)
  note Q = Suc.prems(4)
  note PAQ_B = Suc.prems(5)
  note diag_B = Suc.prems(6)
  let ?Dk = "(diagonal_to_Smith_aux_PQ [0..<k] bezout (P, P ** A ** Q, Q))"
  let ?P' = "fst ?Dk"
  let ?B'="fst (snd ?Dk)"
  let ?Q' = "snd (snd ?Dk)"
  have k: "k<min (nrows A) (ncols A)" using Suc_k by auto
  have hyp: "?B' = ?P' ** A ** ?Q'  invertible ?P'  invertible ?Q' 
       ?B' = diagonal_to_Smith_aux B [0..<k] bezout"
    by (rule Suc.hyps[OF k _ P Q PAQ_B diag_B], auto simp add: PAQ_B)
  have diag_B': "isDiagonal ?B'"
    by (metis diag_B hyp ib isDiagonal_diagonal_to_Smith_aux k ncols_def nrows_def)
  have "B' = diagonal_to_Smith_aux B [0..<Suc k] bezout"
    by (auto, metis Diagonal_to_Smith_row_i_PQ_eq PAQ_B Suc(3) diag_B' 
        diagonal_to_Smith_aux_PQ_append2 eq_fst_iff hyp ib k sndI upt.simps(2) zero_order(1))
  moreover have "B' = P' ** A ** Q'  invertible P'  invertible Q'"
  proof (rule Diagonal_to_Smith_row_i_PQ')
    show "(P', B', Q') = Diagonal_to_Smith_row_i_PQ k bezout (?P',?B',?Q')" using Suc.prems by auto
    show "invertible ?P'" using hyp by auto
    show "?P' ** A ** ?Q' = ?B'" using hyp by auto
    show "invertible ?Q'" using hyp by auto
    show "is_bezout_ext bezout" using ib by auto
    show "k < min (nrows A) (ncols A)" using k by auto
    show diag_B': "isDiagonal ?B'" using diag_B' by auto
  qed 
  ultimately show ?case by auto
qed

end

fun diagonal_to_Smith_PQ 
  where "diagonal_to_Smith_PQ A bezout 
  = diagonal_to_Smith_aux_PQ  [0..<min (nrows A) (ncols A) - 1] bezout (mat 1, A ,mat 1)"

declare diagonal_to_Smith_PQ.simps[simp del]
lemmas diagonal_to_Smith_PQ_def = diagonal_to_Smith_PQ.simps

lemma diagonal_to_Smith_PQ:
  fixes A::"'a::{bezout_ring}^'cols::{mod_type}^'rows::{mod_type}" 
  assumes A: "isDiagonal A" and ib: "is_bezout_ext bezout"
  assumes PBQ: "(P,B,Q) = diagonal_to_Smith_PQ A bezout"
  shows "B = P**A**Q  invertible P  invertible Q  B = diagonal_to_Smith A bezout"   
proof (unfold diagonal_to_Smith_def, rule diagonal_to_Smith_aux_PQ[OF  _ _ _ ib _ A])
  let ?P = "mat 1::'a^'rows::mod_type^'rows::mod_type"
  let ?Q = "mat 1::'a^'cols::mod_type^'cols::mod_type"
  show "(P, B, Q) = diagonal_to_Smith_aux_PQ [0..<min (nrows A) (ncols A) - 1] bezout (?P, A, ?Q)"
    using PBQ unfolding diagonal_to_Smith_PQ_def .
  show "?P ** A ** ?Q = A" by simp
  show " min (nrows A) (ncols A) - 1 < min (nrows A) (ncols A)"    
    by (metis (no_types, lifting) One_nat_def diff_less dual_order.strict_iff_order le_less_trans 
        min_def mod_type_class.to_nat_less_card ncols_def not_less_eq nrows_not_0 zero_order(1))
qed (auto simp add: invertible_mat_1)


lemma diagonal_to_Smith_PQ_exists:
  fixes A::"'a::{bezout_ring}^'cols::{mod_type}^'rows::{mod_type}" 
  assumes A: "isDiagonal A"
  shows "P Q. 
         invertible (P::'a^'rows::{mod_type}^'rows::{mod_type}) 
        invertible (Q::'a^'cols::{mod_type}^'cols::{mod_type})
        Smith_normal_form (P**A**Q)"   
proof -
  obtain bezout::"'a bezout" where ib: "is_bezout_ext bezout"
    using exists_bezout_ext by blast
  obtain P B Q where PBQ: "(P,B,Q) = diagonal_to_Smith_PQ A bezout"
    by (metis prod_cases3)
  have "B = P**A**Q  invertible P  invertible Q  B = diagonal_to_Smith A bezout" 
    by (rule diagonal_to_Smith_PQ[OF A ib PBQ])
  moreover have "Smith_normal_form (P**A**Q)"
    using Smith_normal_form_diagonal_to_Smith assms calculation ib by fastforce
  ultimately show ?thesis by auto
qed

subsection‹The final soundness theorem›

lemma diagonal_to_Smith_PQ':
  fixes A::"'a::{bezout_ring}^'cols::{mod_type}^'rows::{mod_type}" 
  assumes A: "isDiagonal A" and ib: "is_bezout_ext bezout"
  assumes PBQ: "(P,S,Q) = diagonal_to_Smith_PQ A bezout"
  shows "S = P**A**Q  invertible P  invertible Q  Smith_normal_form S"   
  using A PBQ Smith_normal_form_diagonal_to_Smith diagonal_to_Smith_PQ ib by fastforce

end

Theory Mod_Type_Connect

(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section ‹A new bridge to convert theorems from JNF to HOL Analysis and vice-versa, 
based on the @{text "mod_type"} class›

theory Mod_Type_Connect
  imports 
          Perron_Frobenius.HMA_Connect
          Rank_Nullity_Theorem.Mod_Type
          Gauss_Jordan.Elementary_Operations
begin

text ‹Some lemmas on @{text "Mod_Type.to_nat"} and @{text "Mod_Type.from_nat"} are added to have 
them with the same names as the analogous ones for @{text "Bij_Nat.to_nat"} 
and @{text "Bij_Nat.to_nat"}.›

lemma inj_to_nat: "inj to_nat" by (simp add: inj_on_def)
lemmas from_nat_inj = from_nat_eq_imp_eq
lemma range_to_nat: "range (to_nat :: 'a :: mod_type  nat) = {0 ..< CARD('a)}"
  by (simp add: bij_betw_imp_surj_on mod_type_class.bij_to_nat)


text ‹This theory is an adaptation of the one presented in @{text "Perron_Frobenius.HMA_Connect"},
  but for matrices and vectors where indexes have the @{text "mod_type"} class restriction.

  It is worth noting that some definitions still use the old abbreviation for HOL Analysis 
  (HMA, from HOL Multivariate Analysis) instead of HA. This is done to be consistent with 
  the existing names in the Perron-Frobenius development›

context includes vec.lifting 
begin
end

definition from_hmav :: "'a ^ 'n :: mod_type  'a Matrix.vec" where
  "from_hmav v = Matrix.vec CARD('n) (λ i. v $h from_nat i)"

definition from_hmam :: "'a ^ 'nc :: mod_type ^ 'nr :: mod_type  'a Matrix.mat" where
  "from_hmam a = Matrix.mat CARD('nr) CARD('nc) (λ (i,j). a $h from_nat i $h from_nat j)"

definition to_hmav :: "'a Matrix.vec  'a ^ 'n :: mod_type" where
  "to_hmav v = (χ i. v $v to_nat i)"

definition to_hmam :: "'a Matrix.mat  'a ^ 'nc :: mod_type ^ 'nr :: mod_type " where
  "to_hmam a = (χ i j. a $$ (to_nat i, to_nat j))"

lemma to_hma_from_hmav[simp]: "to_hmav (from_hmav v) = v"
  by (auto simp: to_hmav_def from_hmav_def to_nat_less_card)

lemma to_hma_from_hmam[simp]: "to_hmam (from_hmam v) = v"
  by (auto simp: to_hmam_def from_hmam_def to_nat_less_card)

lemma from_hma_to_hmav[simp]:
  "v  carrier_vec (CARD('n))  from_hmav (to_hmav v :: 'a ^ 'n :: mod_type) = v"
  by (auto simp: to_hmav_def from_hmav_def to_nat_from_nat_id)

lemma from_hma_to_hmam[simp]:
  "A  carrier_mat (CARD('nr)) (CARD('nc))  from_hmam (to_hmam A :: 'a ^ 'nc :: mod_type  ^ 'nr :: mod_type) = A"
  by (auto simp: to_hmam_def from_hmam_def to_nat_from_nat_id)

lemma from_hmav_inj[simp]: "from_hmav x = from_hmav y  x = y"
  by (intro iffI, insert to_hma_from_hmav[of x], auto)

lemma from_hmam_inj[simp]: "from_hmam x = from_hmam y  x = y"
  by(intro iffI, insert to_hma_from_hmam[of x], auto)

definition HMA_V :: "'a Matrix.vec  'a ^ 'n :: mod_type  bool" where 
  "HMA_V = (λ v w. v = from_hmav w)"

definition HMA_M :: "'a Matrix.mat  'a ^ 'nc :: mod_type ^ 'nr :: mod_type   bool" where 
  "HMA_M = (λ a b. a = from_hmam b)"

definition HMA_I :: "nat  'n :: mod_type  bool" where
  "HMA_I = (λ i a. i = to_nat a)"



context includes lifting_syntax
begin

lemma Domainp_HMA_V [transfer_domain_rule]: 
  "Domainp (HMA_V :: 'a Matrix.vec  'a ^ 'n :: mod_type  bool) = (λ v. v  carrier_vec (CARD('n )))"
  by(intro ext iffI, insert from_hma_to_hmav[symmetric], auto simp: from_hmav_def HMA_V_def)

lemma Domainp_HMA_M [transfer_domain_rule]: 
  "Domainp (HMA_M :: 'a Matrix.mat  'a ^ 'nc :: mod_type  ^ 'nr :: mod_type  bool) 
  = (λ A. A  carrier_mat CARD('nr) CARD('nc))"
  by (intro ext iffI, insert from_hma_to_hmam[symmetric], auto simp: from_hmam_def HMA_M_def)

lemma Domainp_HMA_I [transfer_domain_rule]: 
  "Domainp (HMA_I :: nat  'n :: mod_type  bool) = (λ i. i < CARD('n))" (is "?l = ?r")
proof (intro ext)
  fix i :: nat
  show "?l i = ?r i"
    unfolding HMA_I_def Domainp_iff
    by (auto intro: exI[of _ "from_nat i"] simp: to_nat_from_nat_id to_nat_less_card)
qed

lemma bi_unique_HMA_V [transfer_rule]: "bi_unique HMA_V" "left_unique HMA_V" "right_unique HMA_V"
  unfolding HMA_V_def bi_unique_def left_unique_def right_unique_def by auto

lemma bi_unique_HMA_M [transfer_rule]: "bi_unique HMA_M" "left_unique HMA_M" "right_unique HMA_M"
  unfolding HMA_M_def bi_unique_def left_unique_def right_unique_def by auto

lemma bi_unique_HMA_I [transfer_rule]: "bi_unique HMA_I" "left_unique HMA_I" "right_unique HMA_I"
  unfolding HMA_I_def bi_unique_def left_unique_def right_unique_def by auto

lemma right_total_HMA_V [transfer_rule]: "right_total HMA_V"
  unfolding HMA_V_def right_total_def by simp

lemma right_total_HMA_M [transfer_rule]: "right_total HMA_M"
  unfolding HMA_M_def right_total_def by simp

lemma right_total_HMA_I [transfer_rule]: "right_total HMA_I"
  unfolding HMA_I_def right_total_def by simp

lemma HMA_V_index [transfer_rule]: "(HMA_V ===> HMA_I ===> (=)) ($v) ($h)"
  unfolding rel_fun_def HMA_V_def HMA_I_def from_hmav_def
  by (auto simp: to_nat_less_card)


lemma HMA_M_index [transfer_rule]:
  "(HMA_M ===> HMA_I ===> HMA_I ===> (=)) (λ A i j. A $$ (i,j)) index_hma"
  by (intro rel_funI, simp add: index_hma_def to_nat_less_card HMA_M_def HMA_I_def from_hmam_def)  


lemma HMA_V_0 [transfer_rule]: "HMA_V (0v CARD('n)) (0 :: 'a :: zero ^ 'n:: mod_type)"
  unfolding HMA_V_def from_hmav_def by auto

lemma HMA_M_0 [transfer_rule]: 
  "HMA_M (0m CARD('nr) CARD('nc)) (0 :: 'a :: zero ^ 'nc:: mod_type  ^ 'nr :: mod_type)"
  unfolding HMA_M_def from_hmam_def by auto

lemma HMA_M_1[transfer_rule]:
  "HMA_M (1m (CARD('n))) (mat 1 :: 'a::{zero,one}^'n:: mod_type^'n:: mod_type)"
  unfolding HMA_M_def
  by (auto simp add: mat_def from_hmam_def from_nat_inj)
 

lemma from_hmav_add: "from_hmav v + from_hmav w = from_hmav (v + w)"
  unfolding from_hmav_def by auto

lemma HMA_V_add [transfer_rule]: "(HMA_V ===> HMA_V ===> HMA_V) (+) (+) "
  unfolding rel_fun_def HMA_V_def
  by (auto simp: from_hmav_add)

lemma from_hmav_diff: "from_hmav v - from_hmav w = from_hmav (v - w)"
  unfolding from_hmav_def by auto

lemma HMA_V_diff [transfer_rule]: "(HMA_V ===> HMA_V ===> HMA_V) (-) (-)"
  unfolding rel_fun_def HMA_V_def
  by (auto simp: from_hmav_diff)

lemma from_hmam_add: "from_hmam a + from_hmam b = from_hmam (a + b)"
  unfolding from_hmam_def by auto

lemma HMA_M_add [transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) (+) (+) "
  unfolding rel_fun_def HMA_M_def
  by (auto simp: from_hmam_add)

lemma from_hmam_diff: "from_hmam a - from_hmam b = from_hmam (a - b)"
  unfolding from_hmam_def by auto

lemma HMA_M_diff [transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) (-) (-) "
  unfolding rel_fun_def HMA_M_def
  by (auto simp: from_hmam_diff)

lemma scalar_product: fixes v :: "'a :: semiring_1 ^ 'n :: mod_type"
  shows "scalar_prod (from_hmav v) (from_hmav w) = scalar_product v w"
  unfolding scalar_product_def scalar_prod_def from_hmav_def dim_vec
  by (simp add: sum.reindex[OF inj_to_nat, unfolded range_to_nat])

lemma [simp]:
  "from_hmam (y :: 'a ^ 'nc :: mod_type ^ 'nr:: mod_type)  carrier_mat (CARD('nr)) (CARD('nc))"
  "dim_row (from_hmam (y :: 'a ^ 'nc:: mod_type  ^ 'nr :: mod_type)) = CARD('nr)"
  "dim_col (from_hmam (y :: 'a ^ 'nc :: mod_type ^ 'nr:: mod_type )) = CARD('nc)"
  unfolding from_hmam_def by simp_all

lemma [simp]:
  "from_hmav (y :: 'a ^ 'n:: mod_type)  carrier_vec (CARD('n))"
  "dim_vec (from_hmav (y :: 'a ^ 'n:: mod_type)) = CARD('n)"
  unfolding from_hmav_def by simp_all

lemma HMA_scalar_prod [transfer_rule]:
  "(HMA_V ===> HMA_V ===> (=)) scalar_prod scalar_product" 
  by (auto simp: HMA_V_def scalar_product)

lemma HMA_row [transfer_rule]: "(HMA_I ===> HMA_M ===> HMA_V) (λ i a. Matrix.row a i) row"
  unfolding HMA_M_def HMA_I_def HMA_V_def
  by (auto simp: from_hmam_def from_hmav_def to_nat_less_card row_def)

lemma HMA_col [transfer_rule]: "(HMA_I ===> HMA_M ===> HMA_V) (λ i a. col a i) column"
  unfolding HMA_M_def HMA_I_def HMA_V_def
  by (auto simp: from_hmam_def from_hmav_def to_nat_less_card column_def)


lemma HMA_M_mk_mat[transfer_rule]: "((HMA_I ===> HMA_I ===> (=)) ===> HMA_M) 
  (λ f. Matrix.mat (CARD('nr)) (CARD('nc)) (λ (i,j). f i j)) 
  (mk_mat :: (('nr  'nc  'a)  'a^'nc:: mod_type^'nr:: mod_type))"
proof-
  {
    fix x y i j
    assume id: " (ya :: 'nr) (yb :: 'nc). (x (to_nat ya) (to_nat yb) :: 'a) = y ya yb"
       and i: "i < CARD('nr)" and j: "j < CARD('nc)"
    from to_nat_from_nat_id[OF i] to_nat_from_nat_id[OF j] id[rule_format, of "from_nat i" "from_nat j"]
    have "x i j = y (from_nat i) (from_nat j)" by auto
  }
  thus ?thesis
    unfolding rel_fun_def mk_mat_def HMA_M_def HMA_I_def from_hmam_def by auto
qed

lemma HMA_M_mk_vec[transfer_rule]: "((HMA_I ===> (=)) ===> HMA_V) 
  (λ f. Matrix.vec (CARD('n)) (λ i. f i)) 
  (mk_vec :: (('n  'a)  'a^'n:: mod_type))"
proof-
  {
    fix x y i
    assume id: " (ya :: 'n). (x (to_nat ya) :: 'a) = y ya"
       and i: "i < CARD('n)" 
    from to_nat_from_nat_id[OF i] id[rule_format, of "from_nat i"]
    have "x i = y (from_nat i)" by auto
  }
  thus ?thesis
    unfolding rel_fun_def mk_vec_def HMA_V_def HMA_I_def from_hmav_def by auto
qed


lemma mat_mult_scalar: "A ** B = mk_mat (λ i j. scalar_product (row i A) (column j B))"
  unfolding vec_eq_iff matrix_matrix_mult_def scalar_product_def mk_mat_def
  by (auto simp: row_def column_def)

lemma mult_mat_vec_scalar: "A *v v = mk_vec (λ i. scalar_product (row i A) v)"
  unfolding vec_eq_iff matrix_vector_mult_def scalar_product_def mk_mat_def mk_vec_def
  by (auto simp: row_def column_def)

lemma dim_row_transfer_rule: 
  "HMA_M A (A' :: 'a ^ 'nc:: mod_type ^ 'nr:: mod_type)  (=) (dim_row A) (CARD('nr))"
  unfolding HMA_M_def by auto

lemma dim_col_transfer_rule: 
  "HMA_M A (A' :: 'a ^ 'nc:: mod_type ^ 'nr:: mod_type)  (=) (dim_col A) (CARD('nc))"
  unfolding HMA_M_def by auto


lemma HMA_M_mult [transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) (*) (**)"
proof -
  {
    fix A B :: "'a :: semiring_1 mat" and A' :: "'a ^ 'n :: mod_type ^ 'nr:: mod_type" 
      and B' :: "'a ^ 'nc :: mod_type ^ 'n:: mod_type"
    assume 1[transfer_rule]: "HMA_M A A'" "HMA_M B B'"
    note [transfer_rule] = dim_row_transfer_rule[OF 1(1)] dim_col_transfer_rule[OF 1(2)]
    have "HMA_M (A * B) (A' ** B')"
      unfolding times_mat_def mat_mult_scalar
      by (transfer_prover_start, transfer_step+, transfer, auto)
  }
  thus ?thesis by blast
qed
      

lemma HMA_V_smult [transfer_rule]: "((=) ===> HMA_V ===> HMA_V) (⋅v) (*s)"
  unfolding smult_vec_def 
  unfolding rel_fun_def HMA_V_def from_hmav_def
  by auto

lemma HMA_M_mult_vec [transfer_rule]: "(HMA_M ===> HMA_V ===> HMA_V) (*v) (*v)"
proof -
  {
    fix A :: "'a :: semiring_1 mat" and v :: "'a Matrix.vec"
      and A' :: "'a ^ 'nc :: mod_type ^ 'nr :: mod_type" and v' :: "'a ^ 'nc :: mod_type"
    assume 1[transfer_rule]: "HMA_M A A'" "HMA_V v v'"
    note [transfer_rule] = dim_row_transfer_rule
    have "HMA_V (A *v v) (A' *v v')"
      unfolding mult_mat_vec_def mult_mat_vec_scalar
      by (transfer_prover_start, transfer_step+, transfer, auto)
  }
  thus ?thesis by blast  
qed


lemma HMA_det [transfer_rule]: "(HMA_M ===> (=)) Determinant.det 
  (det :: 'a :: comm_ring_1 ^ 'n :: mod_type ^ 'n :: mod_type  'a)"
proof -
  {
    fix a :: "'a ^ 'n :: mod_type^ 'n:: mod_type"
    let ?tn = "to_nat :: 'n :: mod_type  nat"
    let ?fn = "from_nat :: nat  'n"
    let ?zn = "{0..< CARD('n)}"
    let ?U = "UNIV :: 'n set"
    let ?p1 = "{p. p permutes ?zn}"
    let ?p2 = "{p. p permutes ?U}"  
    let ?f= "λ p i. if i  ?U then ?fn (p (?tn i)) else i"
    let ?g = "λ p i. ?fn (p (?tn i))"
    have fg: " a b c. (if a  ?U then b else c) = b" by auto
    have "?p2 = ?f ` ?p1" 
      by (rule permutes_bij', auto simp: to_nat_less_card to_nat_from_nat_id)
    hence id: "?p2 = ?g ` ?p1" by simp
    have inj_g: "inj_on ?g ?p1"
      unfolding inj_on_def
    proof (intro ballI impI ext, auto)
      fix p q i
      assume p: "p permutes ?zn" and q: "q permutes ?zn"
        and id: "(λ i. ?fn (p (?tn i))) = (λ i. ?fn (q (?tn i)))"
      {
        fix i
        from permutes_in_image[OF p] have pi: "p (?tn i) < CARD('n)" by (simp add: to_nat_less_card)
        from permutes_in_image[OF q] have qi: "q (?tn i) < CARD('n)" by (simp add: to_nat_less_card)
        from fun_cong[OF id] have "?fn (p (?tn i))  = from_nat (q (?tn i))" .
        from arg_cong[OF this, of ?tn] have "p (?tn i) = q (?tn i)"
          by (simp add: to_nat_from_nat_id pi qi)
      } note id = this             
      show "p i = q i"
      proof (cases "i < CARD('n)")
        case True
        hence "?tn (?fn i) = i" by (simp add: to_nat_from_nat_id)
        from id[of "?fn i", unfolded this] show ?thesis .
      next
        case False
        thus ?thesis using p q unfolding permutes_def by simp
      qed
    qed
    have mult_cong: " a b c d. a = b  c = d  a * c = b * d" by simp
    have "sum (λ p. 
      signof p * (i?zn. a $h ?fn i $h ?fn (p i))) ?p1
      = sum (λ p. of_int (sign p) * (iUNIV. a $h i $h p i)) ?p2"
      unfolding id sum.reindex[OF inj_g]
    proof (rule sum.cong[OF refl], unfold mem_Collect_eq o_def, rule mult_cong)
      fix p
      assume p: "p permutes ?zn"
      let ?q = "λ i. ?fn (p (?tn i))"
      from id p have q: "?q permutes ?U" by auto
      from p have pp: "permutation p" unfolding permutation_permutes by auto
      let ?ft = "λ p i. ?fn (p (?tn i))"
      have fin: "finite ?zn" by simp
      have "sign p = sign ?q  p permutes ?zn"
      proof (induct rule: permutes_induct[OF fin _ _ p])    
        case 1 
        show ?case by (auto simp: sign_id[unfolded id_def] permutes_id[unfolded id_def])
      next
        case (2 a b p)
        let ?sab = "Fun.swap a b id"
        let ?sfab = "Fun.swap (?fn a) (?fn b) id"
        have p_sab: "permutation ?sab" by (rule permutation_swap_id)
        have p_sfab: "permutation ?sfab" by (rule permutation_swap_id)
        from 2(3) have IH1: "p permutes ?zn" and IH2: "sign p = sign (?ft p)" by auto
        have sab_perm: "?sab permutes ?zn" using 2(1-2) by (rule permutes_swap_id)
        from permutes_compose[OF IH1 this] have perm1: "?sab o p permutes ?zn" .
        from IH1 have p_p1: "p  ?p1" by simp
        hence "?ft p  ?ft ` ?p1" by (rule imageI)
        from this[folded id] have "?ft p permutes ?U" by simp
        hence p_ftp: "permutation (?ft p)" unfolding permutation_permutes by auto
        {
          fix a b
          assume a: "a  ?zn" and b: "b  ?zn" 
          hence "(?fn a = ?fn b) = (a = b)" using 2(1-2)
            by (auto simp add: from_nat_eq_imp_eq)
        } note inj = this
        from inj[OF 2(1-2)] have id2: "sign ?sfab = sign ?sab" unfolding sign_swap_id by simp
        have id: "?ft (Fun.swap a b id  p) = Fun.swap (?fn a) (?fn b) id  ?ft p"
        proof
          fix c 
          show "?ft (Fun.swap a b id  p) c = (Fun.swap (?fn a) (?fn b) id  ?ft p) c"
          proof (cases "p (?tn c) = a  p (?tn c) = b")
            case True
            thus ?thesis by (cases, auto simp add: o_def swap_def)
          next
            case False
            hence neq: "p (?tn c)  a" "p (?tn c)  b" by auto
            have pc: "p (?tn c)  ?zn" unfolding permutes_in_image[OF IH1] 
              by (simp add: to_nat_less_card)
            from neq[folded inj[OF pc 2(1)] inj[OF pc 2(2)]]
            have "?fn (p (?tn c))  ?fn a" "?fn (p (?tn c))  ?fn b" .
            with neq show ?thesis by (auto simp: o_def swap_def)
          qed
        qed
        show ?case unfolding IH2 id sign_compose[OF p_sab 2(5)] sign_compose[OF p_sfab p_ftp] id2 
          by (rule conjI[OF refl perm1])
      qed
      thus "signof p = of_int (sign ?q)" unfolding signof_def sign_def by auto
      show "(i = 0..<CARD('n). a $h ?fn i $h ?fn (p i)) =
           (iUNIV. a $h i $h ?q i)" unfolding 
           range_to_nat[symmetric] prod.reindex[OF inj_to_nat]
            by (rule prod.cong[OF refl], unfold o_def, simp)
    qed   
  }
  thus ?thesis unfolding HMA_M_def 
    by (auto simp: from_hmam_def Determinant.det_def det_def)
qed

lemma HMA_mat[transfer_rule]: "((=) ===> HMA_M) (λ k. k m 1m CARD('n)) 
  (Finite_Cartesian_Product.mat :: 'a::semiring_1  'a^'n :: mod_type^'n :: mod_type)"
  unfolding Finite_Cartesian_Product.mat_def[abs_def] rel_fun_def HMA_M_def
  by (auto simp: from_hmam_def from_nat_inj)


lemma HMA_mat_minus[transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) 
  (λ A B. A + map_mat uminus B) ((-) :: 'a :: group_add ^'nc:: mod_type^'nr:: mod_type 
   'a^'nc:: mod_type^'nr:: mod_type  'a^'nc:: mod_type^'nr:: mod_type)"
  unfolding rel_fun_def HMA_M_def from_hmam_def by auto

lemma HMA_transpose_matrix [transfer_rule]: 
  "(HMA_M ===> HMA_M) transpose_mat transpose"
  unfolding transpose_mat_def transpose_def HMA_M_def from_hmam_def by auto


lemma HMA_invertible_matrix_mod_type[transfer_rule]: 
  "((Mod_Type_Connect.HMA_M :: _  'a :: comm_ring_1 ^ 'n :: mod_type ^ 'n :: mod_type 
       _) ===> (=)) invertible_mat invertible" 
proof (intro rel_funI, goal_cases)
  case (1 x y)
  note rel_xy[transfer_rule] = "1"
  have eq_dim: "dim_col x = dim_row x"
    using Mod_Type_Connect.dim_col_transfer_rule Mod_Type_Connect.dim_row_transfer_rule rel_xy 
    by fastforce    
  moreover have "A'. y ** A' = mat 1  A' ** y = mat 1" 
    if xB: "x * B = 1m (dim_row x)" and Bx: "B * x = 1m (dim_row B)" for B
  proof -
    let ?A' = "Mod_Type_Connect.to_hmam B:: 'a :: comm_ring_1 ^ 'n :: mod_type^ 'n :: mod_type" 
    have rel_BA[transfer_rule]: "Mod_Type_Connect.HMA_M B ?A'"
      by (metis (no_types, lifting) Bx Mod_Type_Connect.HMA_M_def eq_dim carrier_mat_triv dim_col_mat(1)
          Mod_Type_Connect.from_hmam_def Mod_Type_Connect.from_hma_to_hmam index_mult_mat(3) 
          index_one_mat(3) rel_xy xB)
    have [simp]: "dim_row B = CARD('n)" using Mod_Type_Connect.dim_row_transfer_rule rel_BA by blast
    have [simp]: "dim_row x = CARD('n)" using Mod_Type_Connect.dim_row_transfer_rule rel_xy by blast
    have "y ** ?A' = mat 1" using xB by (transfer, simp)
    moreover have "?A' ** y  = mat 1" using Bx by (transfer, simp)
    ultimately show ?thesis by blast
  qed
  moreover have "B. x * B = 1m (dim_row x)  B * x = 1m (dim_row B)"
    if yA: "y ** A' = mat 1" and Ay: "A' ** y = mat 1" for A'
  proof -
    let ?B = "(Mod_Type_Connect.from_hmam A')"
    have [simp]: "dim_row x = CARD('n)" using rel_xy Mod_Type_Connect.dim_row_transfer_rule by blast
    have [transfer_rule]: "Mod_Type_Connect.HMA_M ?B A'" by (simp add: Mod_Type_Connect.HMA_M_def)
    hence [simp]: "dim_row ?B = CARD('n)" using dim_row_transfer_rule by auto
    have "x * ?B = 1m (dim_row x)" using yA by (transfer', auto)
    moreover have "?B * x = 1m (dim_row ?B)" using Ay by (transfer', auto)
    ultimately show ?thesis by auto
  qed
  ultimately show ?case unfolding invertible_mat_def invertible_def inverts_mat_def by auto
qed


end


text ‹Some transfer rules for relating the elementary operations are also proved.›

context
  includes lifting_syntax
begin

lemma HMA_swaprows[transfer_rule]: 
  "((Mod_Type_Connect.HMA_M :: _  'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type  _)
    ===> (Mod_Type_Connect.HMA_I :: _ 'nr :: mod_type  _ )
    ===> (Mod_Type_Connect.HMA_I :: _ 'nr :: mod_type  _ )     
    ===> Mod_Type_Connect.HMA_M) 
    (λA a b. swaprows a b A) interchange_rows" 
  by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def interchange_rows_def)
     (rule eq_matI, auto simp add: Mod_Type_Connect.from_hmam_def Mod_Type_Connect.HMA_I_def 
      to_nat_less_card to_nat_from_nat_id)

lemma HMA_swapcols[transfer_rule]: 
  "((Mod_Type_Connect.HMA_M :: _  'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type  _)
    ===> (Mod_Type_Connect.HMA_I :: _ 'nc :: mod_type  _ )
    ===> (Mod_Type_Connect.HMA_I :: _ 'nc :: mod_type  _ )     
    ===> Mod_Type_Connect.HMA_M) 
    (λA a b. swapcols a b A) interchange_columns" 
  by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def interchange_columns_def)
     (rule eq_matI, auto simp add: Mod_Type_Connect.from_hmam_def Mod_Type_Connect.HMA_I_def 
      to_nat_less_card to_nat_from_nat_id)

lemma HMA_addrow[transfer_rule]: 
  "((Mod_Type_Connect.HMA_M :: _  'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type  _) 
    ===> (Mod_Type_Connect.HMA_I :: _ 'nr :: mod_type  _ )
    ===> (Mod_Type_Connect.HMA_I :: _ 'nr :: mod_type  _ ) 
    ===> (=)
    ===> Mod_Type_Connect.HMA_M) 
    (λA a b q. addrow q a b A) row_add"
  by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def row_add_def)
     (rule eq_matI, auto simp add: Mod_Type_Connect.from_hmam_def Mod_Type_Connect.HMA_I_def 
      to_nat_less_card to_nat_from_nat_id)

lemma HMA_addcol[transfer_rule]: 
  "((Mod_Type_Connect.HMA_M :: _  'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type  _) 
    ===> (Mod_Type_Connect.HMA_I :: _ 'nc :: mod_type  _ )
    ===> (Mod_Type_Connect.HMA_I :: _ 'nc :: mod_type  _ ) 
    ===> (=)
    ===> Mod_Type_Connect.HMA_M) 
    (λA a b q. addcol q a b A) column_add"
  by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def column_add_def)
     (rule eq_matI, auto simp add: Mod_Type_Connect.from_hmam_def Mod_Type_Connect.HMA_I_def 
      to_nat_less_card to_nat_from_nat_id)

lemma HMA_multrow[transfer_rule]: 
  "((Mod_Type_Connect.HMA_M :: _  'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type  _)
    ===> (Mod_Type_Connect.HMA_I :: _ 'nr :: mod_type  _ )
    ===> (=)     
    ===> Mod_Type_Connect.HMA_M) 
    (λA i q. multrow i q A) mult_row"
  by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def mult_row_def)
     (rule eq_matI, auto simp add: Mod_Type_Connect.from_hmam_def Mod_Type_Connect.HMA_I_def 
      to_nat_less_card to_nat_from_nat_id)

lemma HMA_multcol[transfer_rule]: 
  "((Mod_Type_Connect.HMA_M :: _  'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type  _)
    ===> (Mod_Type_Connect.HMA_I :: _ 'nc :: mod_type  _ )
    ===> (=)     
    ===> Mod_Type_Connect.HMA_M) 
    (λA i q. multcol i q A) mult_column"
  by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def mult_column_def)
     (rule eq_matI, auto simp add: Mod_Type_Connect.from_hmam_def Mod_Type_Connect.HMA_I_def 
      to_nat_less_card to_nat_from_nat_id)

end

fun HMA_M3 where
  "HMA_M3 (P,A,Q) 
  (P' :: 'a :: comm_ring_1 ^ 'nr :: mod_type ^ 'nr :: mod_type,
   A' :: 'a ^ 'nc :: mod_type ^ 'nr :: mod_type,
   Q' :: 'a ^ 'nc :: mod_type ^ 'nc :: mod_type) = 
  (Mod_Type_Connect.HMA_M P P'  Mod_Type_Connect.HMA_M A A'  Mod_Type_Connect.HMA_M Q Q')"

lemma HMA_M3_def: 
  "HMA_M3 A B = (Mod_Type_Connect.HMA_M (fst A) (fst B) 
   Mod_Type_Connect.HMA_M (fst (snd A)) (fst (snd B)) 
   Mod_Type_Connect.HMA_M (snd (snd A)) (snd (snd B)))"  
  by (smt HMA_M3.simps prod.collapse)


context 
  includes lifting_syntax
begin

lemma Domainp_HMA_M3 [transfer_domain_rule]: 
 "Domainp (HMA_M3 :: _(_×('a::comm_ring_1^'nc::mod_type^'nr::mod_type)×_)_) 
 = (λ(P,A,Q). P  carrier_mat CARD('nr) CARD('nr)  A  carrier_mat CARD('nr) CARD('nc) 
   Q  carrier_mat CARD('nc) CARD('nc))"
proof -
  let ?HMA_M3 = "HMA_M3::_(_×('a::comm_ring_1^'nc::mod_type^'nr::mod_type)×_)_"
  have 1: "P  carrier_mat CARD('nr) CARD('nr) 
         A  carrier_mat CARD('nr) CARD('nc)  Q  carrier_mat CARD('nc) CARD('nc)"
    if "Domainp ?HMA_M3 (P,A,Q)" for P A Q
      using that unfolding Domainp_iff by (auto simp add: Mod_Type_Connect.HMA_M_def)  
  have 2: "Domainp ?HMA_M3 (P,A,Q)" if PAQ: "P  carrier_mat CARD('nr) CARD('nr)
    A  carrier_mat CARD('nr) CARD('nc) Q  carrier_mat CARD('nc) CARD('nc)" for P A Q
  proof -
     let ?P = "Mod_Type_Connect.to_hmam P::'a^'nr::mod_type^'nr::mod_type"
     let ?A = "Mod_Type_Connect.to_hmam A::'a^'nc::mod_type^'nr::mod_type"
     let ?Q = "Mod_Type_Connect.to_hmam Q::'a^'nc::mod_type^'nc::mod_type"
     have "HMA_M3 (P,A,Q) (?P,?A,?Q)"
       by (auto simp add: Mod_Type_Connect.HMA_M_def PAQ)  
     thus ?thesis unfolding Domainp_iff by auto
   qed  
   have "fst x  carrier_mat CARD('nr) CARD('nr)  fst (snd x)  carrier_mat CARD('nr) CARD('nc) 
       (snd (snd x))  carrier_mat CARD('nc) CARD('nc)"
    if "Domainp ?HMA_M3 x" for x using 1
    by (metis (full_types) surjective_pairing that)
  moreover have "Domainp ?HMA_M3 x" 
    if "fst x  carrier_mat CARD('nr) CARD('nr)  fst (snd x)  carrier_mat CARD('nr) CARD('nc) 
       (snd (snd x))  carrier_mat CARD('nc) CARD('nc)" for x 
    using 2
    by (metis (full_types) surjective_pairing that)
  ultimately show ?thesis by (intro ext iffI, unfold split_beta, metis+) 
qed

lemma bi_unique_HMA_M3 [transfer_rule]: "bi_unique HMA_M3" "left_unique HMA_M3" "right_unique HMA_M3"
  unfolding HMA_M3_def bi_unique_def left_unique_def right_unique_def
  by (auto simp add: Mod_Type_Connect.HMA_M_def)

lemma right_total_HMA_M3 [transfer_rule]: "right_total HMA_M3"
  unfolding HMA_M_def right_total_def
  by (simp add: Mod_Type_Connect.HMA_M_def)

end

(*
  TODO: add more theorems to connect everything from HA to JNF in this setting.
*)
end

Theory SNF_Missing_Lemmas

(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section ‹Missing results›

theory SNF_Missing_Lemmas
  imports
    Hermite.Hermite
    Mod_Type_Connect
    Jordan_Normal_Form.DL_Rank_Submatrix
    "List-Index.List_Index"
begin

text ‹This theory presents some missing lemmas that are required for the Smith normal form
development. Some of them could be added to different AFP entries, such as the Jordan Normal
Form AFP entry by Ren\'e Thiemann and Akihisa Yamada.

However, not all the lemmas can be added directly, since some imports are required.›

hide_const (open) C
hide_const (open) measure

subsection ‹Miscellaneous lemmas›

lemma sum_two_rw: "(i = 0..<2. f i) = (i  {0,1::nat}. f i)"
  by (rule sum.cong, auto)

lemma sum_common_left:
  fixes f::"'a  'b::comm_ring_1"
  assumes "finite A"
  shows "sum (λi. c * f i) A = c * sum f A"
  by (simp add: mult_hom.hom_sum)

lemma prod3_intro:
  assumes "fst A = a" and "fst (snd A) = b" and "snd (snd A) = c"
  shows "A = (a,b,c)" using assms by auto


subsection ‹Transfer rules for the HMA\_Connect file of the Perron-Frobenius development›

hide_const (open) HMA_M HMA_I to_hmam from_hmam
hide_fact (open) from_hmam_def from_hma_to_hmam HMA_M_def HMA_I_def dim_row_transfer_rule
                  dim_col_transfer_rule

context
  includes lifting_syntax
begin

lemma HMA_invertible_matrix[transfer_rule]:
  "((HMA_Connect.HMA_M :: _  'a :: comm_ring_1 ^ 'n ^ 'n  _) ===> (=)) invertible_mat invertible"
proof (intro rel_funI, goal_cases)
  case (1 x y)
  note rel_xy[transfer_rule] = "1"
  have eq_dim: "dim_col x = dim_row x"
    using HMA_Connect.dim_col_transfer_rule HMA_Connect.dim_row_transfer_rule rel_xy
    by fastforce
  moreover have "A'. y ** A' = Finite_Cartesian_Product.mat 1  A' ** y = Finite_Cartesian_Product.mat 1"
    if xB: "x * B = 1m (dim_row x)" and Bx: "B * x = 1m (dim_row B)" for B
  proof -
    let ?A' = "HMA_Connect.to_hmam B:: 'a :: comm_ring_1 ^ 'n ^ 'n"
    have rel_BA[transfer_rule]: "HMA_M B ?A'"
      by (metis (no_types, lifting) Bx HMA_M_def eq_dim carrier_mat_triv dim_col_mat(1)
          from_hmam_def from_hma_to_hmam index_mult_mat(3) index_one_mat(3) rel_xy xB)
    have [simp]: "dim_row B = CARD('n)" using dim_row_transfer_rule rel_BA by blast
    have [simp]: "dim_row x = CARD('n)" using dim_row_transfer_rule rel_xy by blast
    have "y ** ?A' = Finite_Cartesian_Product.mat 1" using xB by (transfer, simp)
    moreover have "?A' ** y  = Finite_Cartesian_Product.mat 1" using Bx by (transfer, simp)
    ultimately show ?thesis by blast
  qed
  moreover have "B. x * B = 1m (dim_row x)  B * x = 1m (dim_row B)"
    if yA: "y ** A' = Finite_Cartesian_Product.mat 1" and Ay: "A' ** y = Finite_Cartesian_Product.mat 1" for A'
  proof -
    let ?B = "(from_hmam A')"
    have [simp]: "dim_row x = CARD('n)" using dim_row_transfer_rule rel_xy by blast
    have [transfer_rule]: "HMA_M ?B A'" by (simp add: HMA_M_def)
    hence [simp]: "dim_row ?B = CARD('n)" using dim_row_transfer_rule by auto
    have "x * ?B = 1m (dim_row x)" using yA by (transfer', auto)
    moreover have "?B * x = 1m (dim_row ?B)" using Ay by (transfer', auto)
    ultimately show ?thesis by auto
  qed
  ultimately show ?case unfolding invertible_mat_def invertible_def inverts_mat_def by auto
qed
end

subsection ‹Lemmas obtained from HOL Analysis using local type definitions›

thm Cartesian_Space.invertible_mult (*In HOL Analysis*)
thm invertible_iff_is_unit (*In HOL Analysis*)
thm det_non_zero_imp_unit (*In JNF, but only for fields*)
thm mat_mult_left_right_inverse (*In JNF, but only for fields*)

lemma invertible_mat_zero:
  assumes A: "A  carrier_mat 0 0"
  shows "invertible_mat A"
  using A unfolding invertible_mat_def inverts_mat_def one_mat_def times_mat_def scalar_prod_def
    Matrix.row_def col_def carrier_mat_def
  by (auto, metis (no_types, lifting) cong_mat not_less_zero)

lemma invertible_mult_JNF:
  fixes A::"'a::comm_ring_1 mat"
  assumes A: "Acarrier_mat n n" and B: "Bcarrier_mat n n"
    and inv_A: "invertible_mat A" and inv_B: "invertible_mat B"
shows "invertible_mat (A*B)"
proof (cases "n = 0")
  case True
  then show ?thesis using assms
    by (simp add: invertible_mat_zero)
next
  case False
  then show ?thesis using
      invertible_mult[where ?'a="'a::comm_ring_1", where ?'b="'n::finite", where ?'c="'n::finite",
      where ?'d="'n::finite", untransferred, cancel_card_constraint, OF assms] by auto
qed

lemma invertible_iff_is_unit_JNF:
  assumes A: "A  carrier_mat n n"
  shows "invertible_mat A  (Determinant.det A) dvd 1"
proof (cases "n=0")
  case True
  then show ?thesis using det_dim_zero invertible_mat_zero A by auto
next
  case False
  then show ?thesis using invertible_iff_is_unit[untransferred, cancel_card_constraint] A by auto
qed


subsection ‹Lemmas about matrices, submatrices and determinants›

(*This is a generalization of thm mat_mult_left_right_inverse*)
thm mat_mult_left_right_inverse
lemma mat_mult_left_right_inverse:
  fixes A :: "'a::comm_ring_1 mat"
  assumes A: "A  carrier_mat n n"
    and B: "B  carrier_mat n n" and AB: "A * B = 1m n"
  shows "B * A = 1m n"
proof -
  have "Determinant.det (A * B) = Determinant.det (1m n)" using AB by auto
  hence "Determinant.det A * Determinant.det B = 1"
    using Determinant.det_mult[OF A B] det_one by auto
  hence det_A: "(Determinant.det A) dvd 1" and det_B: "(Determinant.det B) dvd 1"
    using dvd_triv_left dvd_triv_right by metis+
  hence inv_A: "invertible_mat A" and inv_B: "invertible_mat B"
    using A B invertible_iff_is_unit_JNF by blast+
  obtain B' where inv_BB': "inverts_mat B B'" and inv_B'B: "inverts_mat B' B"
    using inv_B unfolding invertible_mat_def by auto
  have B'_carrier: "B'  carrier_mat n n"
    by (metis B inv_B'B inv_BB' carrier_matD(1) carrier_matD(2) carrier_mat_triv
        index_mult_mat(3) index_one_mat(3) inverts_mat_def)
  have "B * A * B = B" using A AB B by auto
  hence "B * A * (B * B') = B * B'"
    by (smt A AB B B'_carrier assoc_mult_mat carrier_matD(1) inv_BB' inverts_mat_def one_carrier_mat)
  thus ?thesis
    by (metis A B carrier_matD(1) carrier_matD(2) index_mult_mat(3) inv_BB'
        inverts_mat_def right_mult_one_mat')
qed

context comm_ring_1
begin

lemma col_submatrix_UNIV:
assumes "j < card {i. i < dim_col A  i  J}"
shows "col (submatrix A UNIV J) j = col A (pick J j)"
proof (rule eq_vecI)
  show dim_eq:"dim_vec (col (submatrix A UNIV J) j) = dim_vec (col A (pick J j))"
    by (simp add: dim_submatrix(1))
  fix i assume "i < dim_vec (col A (pick J j))"
  show "col (submatrix A UNIV J) j $v i = col A (pick J j) $v i"
    by (smt Collect_cong assms col_def dim_col dim_eq dim_submatrix(1)
        eq_vecI index_vec pick_UNIV submatrix_index)
qed

lemma submatrix_split2: "submatrix A I J = submatrix (submatrix A I UNIV) UNIV J" (is "?lhs = ?rhs")
proof (rule eq_matI)
  show dr: "dim_row ?lhs = dim_row ?rhs"
    by (simp add: dim_submatrix(1))
  show dc: "dim_col ?lhs = dim_col ?rhs"
    by (simp add: dim_submatrix(2))
  fix i j assume i: "i < dim_row ?rhs"
    and j: "j < dim_col ?rhs"
  have "?rhs $$ (i, j) = (submatrix A I UNIV) $$ (pick UNIV i, pick J j)"
  proof (rule submatrix_index)
    show "i < card {i. i < dim_row (submatrix A I UNIV)  i  UNIV}"
      by (metis (full_types) dim_submatrix(1) i)
    show "j < card {j. j < dim_col (submatrix A I UNIV)  j  J}"
      by (metis (full_types) dim_submatrix(2) j)
  qed
  also have "... = A $$ (pick I (pick UNIV i), pick UNIV (pick J j))"
  proof (rule submatrix_index)
    show "pick UNIV i < card {i. i < dim_row A  i  I}"
      by (metis (full_types) dr dim_submatrix(1) i pick_UNIV)
    show "pick J j < card {j. j < dim_col A  j  UNIV}"
      by (metis (full_types) dim_submatrix(2) j pick_le)
  qed
  also have "... = ?lhs $$ (i,j)"
  proof (unfold pick_UNIV, rule submatrix_index[symmetric])
    show "i < card {i. i < dim_row A  i  I}"
      by (metis (full_types) dim_submatrix(1) dr i)
    show "j < card {j. j < dim_col A  j  J}"
      by (metis (full_types) dim_submatrix(2) dc j)
  qed
  finally show "?lhs $$ (i, j) = ?rhs $$ (i, j)" ..
qed

lemma submatrix_mult:
  "submatrix (A*B) I J = submatrix A I UNIV * submatrix B UNIV J" (is "?lhs = ?rhs")
proof (rule eq_matI)
  show "dim_row ?lhs = dim_row ?rhs" unfolding submatrix_def by auto
  show "dim_col ?lhs = dim_col ?rhs" unfolding submatrix_def by auto
  fix i j assume i: "i < dim_row ?rhs" and j: "j < dim_col ?rhs"
  have i1: "i < card {i. i < dim_row (A * B)  i  I}"
    by (metis (full_types) dim_submatrix(1) i index_mult_mat(2))
  have j1: "j < card {j. j < dim_col (A * B)  j  J}"
    by (metis dim_submatrix(2) index_mult_mat(3) j)
  have pi: "pick I i < dim_row A" using i1 pick_le by auto
  have pj: "pick J j < dim_col B" using j1 pick_le by auto
  have row_rw: "Matrix.row (submatrix A I UNIV) i = Matrix.row A (pick I i)"
    using i1 row_submatrix_UNIV by auto
  have col_rw: "col (submatrix B UNIV J) j = col B (pick J j)" using j1 col_submatrix_UNIV by auto
  have "?lhs $$ (i,j) =  (A*B) $$ (pick I i, pick J j)" by (rule submatrix_index[OF i1 j1])
  also have "... = Matrix.row A (pick I i)  col B (pick J j)" by (rule index_mult_mat(1)[OF pi pj])
  also have "... = Matrix.row (submatrix A I UNIV) i  col (submatrix B UNIV J) j"
    using row_rw col_rw by simp
  also have "... = (?rhs) $$ (i,j)" by (rule index_mult_mat[symmetric], insert i j, auto)
  finally show "?lhs $$ (i, j) = ?rhs $$ (i, j)" .
qed

lemma det_singleton:
  assumes A: "A  carrier_mat 1 1"
  shows "det A = A $$ (0,0)"
  using A unfolding carrier_mat_def Determinant.det_def by auto

lemma submatrix_singleton_index:
  assumes A: "A  carrier_mat n m"
    and an: "a < n" and bm: "b < m"
    shows "submatrix A {a} {b} $$ (0,0) = A $$ (a,b)"
proof -
  have a: "{i. i = a  i < dim_row A} = {a}" using an A unfolding carrier_mat_def by auto
  have b: "{i. i = b  i < dim_col A} = {b}" using bm A unfolding carrier_mat_def by auto
  have "submatrix A {a} {b} $$ (0,0) = A $$ (pick {a} 0,pick {b} 0)"
    by (rule submatrix_index, insert a b, auto)
  moreover have "pick {a} 0 = a" by (auto, metis (full_types) LeastI)
  moreover have "pick {b} 0 = b" by (auto, metis (full_types) LeastI)
  ultimately show ?thesis by simp
qed
end

lemma det_not_inj_on:
  assumes not_inj_on: "¬ inj_on f {0..<n}"
  shows "det (matr n n (λi. Matrix.row B (f i))) = 0"
proof -
  obtain i j where i: "i<n" and j: "j<n" and fi_fj: "f i = f j" and ij: "ij"
    using not_inj_on unfolding inj_on_def by auto
  show ?thesis
  proof (rule det_identical_rows[OF _ ij i j])
    let ?B="(matr n n (λi. row B (f i)))"
    show "row ?B i = row ?B j"
    proof (rule eq_vecI, auto)
      fix ia assume ia: "ia < n"
      have "row ?B i $ ia = ?B $$ (i, ia)" by (rule index_row(1), insert i ia, auto)
      also have "... = ?B $$ (j, ia)" by (simp add: fi_fj i ia j)
      also have "... = row ?B j $ ia" by (rule index_row(1)[symmetric], insert j ia, auto)
      finally show "row ?B i $ ia = row (matr n n (λi. row B (f i))) j $ ia" by simp
    qed
    show "matr n n (λi. Matrix.row B (f i))  carrier_mat n n" by auto
  qed
qed



lemma mat_row_transpose: "(matr nr nc f)T = mat nc nr (λ(i,j). vec_index (f j) i)"
  by (rule eq_matI, auto)


lemma obtain_inverse_matrix:
  assumes A: "A  carrier_mat n n" and i: "invertible_mat A"
  obtains B where "inverts_mat A B" and "inverts_mat B A" and "B  carrier_mat n n"
proof -
  have "(B. inverts_mat A B  inverts_mat B A)" using i unfolding invertible_mat_def by auto
  from this obtain B where AB: "inverts_mat A B" and BA: "inverts_mat B A" by auto
  moreover have "B  carrier_mat n n" using A AB BA unfolding carrier_mat_def inverts_mat_def
    by (auto, metis index_mult_mat(3) index_one_mat(3))+
  ultimately show ?thesis using that by blast
qed


lemma invertible_mat_smult_mat:
  fixes A :: "'a::comm_ring_1 mat"
  assumes inv_A: "invertible_mat A" and k: "k dvd 1"
  shows "invertible_mat (k m A)"
proof -
  obtain n where A: "A  carrier_mat n n" using inv_A unfolding invertible_mat_def by auto
  have det_dvd_1: "Determinant.det A dvd 1" using inv_A invertible_iff_is_unit_JNF[OF A] by auto
  have "Determinant.det (k m A) = k ^ dim_col A * Determinant.det A" by simp
  also have "... dvd 1" by (rule unit_prod, insert k det_dvd_1 dvd_power_same, force+)
  finally show ?thesis using invertible_iff_is_unit_JNF by (metis A smult_carrier_mat)
qed

lemma invertible_mat_one[simp]: "invertible_mat (1m n)"
  unfolding invertible_mat_def using inverts_mat_def by fastforce

lemma four_block_mat_dim0:
  assumes A: "A  carrier_mat n n"
  and B: "B  carrier_mat n 0"
  and C: "C  carrier_mat 0 n"
  and D: "D  carrier_mat 0 0"
shows "four_block_mat A B C D = A"
  unfolding four_block_mat_def using assms by auto


lemma det_four_block_mat_lower_right_id:
  assumes A: "A  carrier_mat m m"
and B: "B = 0m m (n-m)"
and C: "C = 0m (n-m) m"
and D: "D = 1m (n-m)"
and "n>m"
shows "Determinant.det (four_block_mat A B C D) = Determinant.det A"
  using assms
proof (induct n arbitrary: A B C D)
  case 0
  then show ?case by auto
next
  case (Suc n)
  let ?block = "(four_block_mat A B C D)"
  let ?B = "Matrix.mat m (n-m) (λ(i,j). 0)"
  let ?C = "Matrix.mat (n-m) m (λ(i,j). 0)"
  let ?D = "1m (n-m)"
  have mat_eq: "(mat_delete ?block n n) = four_block_mat A ?B ?C ?D" (is "?lhs = ?rhs")
  proof (rule eq_matI)
    fix i j assume i: "i < dim_row (four_block_mat A ?B ?C ?D)"
      and j: "j < dim_col (four_block_mat A ?B ?C ?D)"
    let ?f = " (if i < dim_row A then if j < dim_col A then A $$ (i, j) else B $$ (i, j - dim_col A)
     else if j < dim_col A then C $$ (i - dim_row A, j) else D $$ (i - dim_row A, j - dim_col A))"
    let ?g = "(if i < dim_row A then if j < dim_col A then A $$ (i, j) else ?B $$ (i, j - dim_col A)
     else if j < dim_col A then ?C $$ (i - dim_row A, j) else ?D $$ (i - dim_row A, j - dim_col A))"
    have "(mat_delete ?block n n) $$ (i,j) = ?block $$ (i,j)"
      using i j Suc.prems unfolding mat_delete_def by auto
    also have "... = ?f"
      by (rule index_mat_four_block, insert Suc.prems i j, auto)
    also have "... = ?g" using i j Suc.prems by auto
    also have "... = four_block_mat A ?B ?C ?D $$ (i,j)"
      by (rule index_mat_four_block[symmetric], insert Suc.prems i j, auto)
    finally show "?lhs $$ (i,j) = ?rhs $$ (i,j)" .
  qed (insert Suc.prems, auto)
  have nn_1: "?block $$ (n, n) = 1" using Suc.prems by auto
  have rw0: "(i<n. ?block $$ (i,n) * Determinant.cofactor ?block i n) = 0"
  proof (rule sum.neutral, rule)
    fix x assume x: "x  {..<n}"
    have block_index: "?block $$ (x,n) = (if x < dim_row A then if n < dim_col A then A $$ (x, n)
      else B $$ (x, n - dim_col A) else if n < dim_col A then C $$ (x - dim_row A, n)
      else D $$ (x - dim_row A, n - dim_col A))"
      by (rule index_mat_four_block, insert Suc.prems x, auto)
    have "four_block_mat A B C D $$ (x,n) = 0" using x Suc.prems by auto
    thus "four_block_mat A B C D $$ (x, n) * Determinant.cofactor (four_block_mat A B C D) x n = 0"
      by simp
  qed
  have "Determinant.det ?block = (i<Suc n. ?block $$ (i, n) * Determinant.cofactor ?block i n)"
    by (rule laplace_expansion_column, insert Suc.prems, auto)
  also have "... = ?block $$ (n, n) * Determinant.cofactor ?block n n
    + (i<n. ?block $$ (i,n) * Determinant.cofactor ?block i n)"
    by simp
  also have "... = ?block $$ (n, n) * Determinant.cofactor ?block n n" using rw0 by auto
  also have "... = Determinant.cofactor ?block n n" using nn_1 by simp
  also have "... = Determinant.det (mat_delete ?block n n)" unfolding cofactor_def by auto
  also have "... = Determinant.det (four_block_mat A ?B ?C ?D)" using mat_eq by simp
  also have "... = Determinant.det A" (is "Determinant.det ?lhs = Determinant.det ?rhs")
  proof (cases "n = m")
    case True
    have "?lhs = ?rhs" by (rule four_block_mat_dim0, insert Suc.prems True, auto)
    then show ?thesis by simp
  next
    case False
    show ?thesis by (rule Suc.hyps, insert Suc.prems False, auto)
  qed
  finally show ?case .
qed


lemma mult_eq_first_row:
  assumes A: "A  carrier_mat 1 n"
  and B: "B  carrier_mat m n"
  and m0: "m  0"
  and r: "Matrix.row A 0 = Matrix.row B 0"
shows "Matrix.row (A * V) 0 = Matrix.row (B * V) 0"
proof (rule eq_vecI)
  show "dim_vec (Matrix.row (A * V) 0) = dim_vec (Matrix.row (B * V) 0)" using A B r by auto
  fix i assume i: "i < dim_vec (Matrix.row (B * V) 0)"
  have "Matrix.row (A * V) 0 $v i = (A * V) $$ (0,i)" by (rule index_row, insert i A, auto)
  also have "... = Matrix.row A 0  col V i" by (rule index_mult_mat, insert A i, auto)
  also have "... = Matrix.row B 0  col V i" using r by auto
  also have "... = (B * V) $$ (0,i)" by (rule index_mult_mat[symmetric], insert m0 B i, auto)
  also have "... = Matrix.row (B * V) 0 $v i" by (rule index_row[symmetric], insert i B m0, auto)
  finally show "Matrix.row (A * V) 0 $v i = Matrix.row (B * V) 0 $v i" .
qed


lemma smult_mat_mat_one_element:
  assumes A: "A  carrier_mat 1 1" and B: "B  carrier_mat 1 n"
  shows "A * B = A $$ (0,0) m B"
proof (rule eq_matI)
  fix i j assume i: "i < dim_row (A $$ (0, 0) m B)" and j: "j < dim_col (A $$ (0, 0) m B)"
  have i0: "i = 0" using A B i by auto
  have "(A * B) $$ (i, j) =  Matrix.row A i  col B j"
    by (rule index_mult_mat, insert i j A B, auto)
  also have "... =  Matrix.row A i $v 0 * col B j $v 0" unfolding scalar_prod_def using B by auto
  also have "... = A$$(i,i) * B$$(i,j)" using A i i0 j by auto
  also have "... = (A $$ (i, i) m B) $$ (i, j)"
    unfolding i by (rule index_smult_mat[symmetric], insert i j B, auto)
  finally show "(A * B) $$ (i, j) = (A $$ (0, 0) m B) $$ (i, j)" using i0 by simp
qed (insert A B, auto)

lemma determinant_one_element:
  assumes A: "A  carrier_mat 1 1" shows "Determinant.det A = A $$ (0,0)"
proof -
  have "Determinant.det A = prod_list (diag_mat A)"
    by (rule det_upper_triangular[OF _ A], insert A, unfold upper_triangular_def, auto)
  also have "... = A $$ (0,0)" using A unfolding diag_mat_def by auto
  finally show ?thesis .
qed



lemma invertible_mat_transpose:
  assumes inv_A: "invertible_mat (A::'a::comm_ring_1 mat)"
  shows "invertible_mat AT"
proof -
  obtain n where A: "A  carrier_mat n n"
    using inv_A unfolding invertible_mat_def square_mat.simps by auto
  hence At: "AT  carrier_mat n n" by simp
  have "Determinant.det AT = Determinant.det A"
    by (metis Determinant.det_def Determinant.det_transpose carrier_matI
        index_transpose_mat(2) index_transpose_mat(3))
  also have "... dvd 1" using invertible_iff_is_unit_JNF[OF A] inv_A by simp
  finally show ?thesis  using invertible_iff_is_unit_JNF[OF At] by auto
qed

lemma dvd_elements_mult_matrix_left:
  assumes A: "(A::'a::comm_ring_1 mat)  carrier_mat m n"
  and P: "P  carrier_mat m m"
  and x: "(i j. i<m  j<n  x dvd A$$(i,j))"
  shows "(i j. i<m  j<n  x dvd (P*A)$$(i,j))"
proof -
  have "x dvd (P * A) $$ (i, j)" if i: "i < m" and j: "j < n" for i j
  proof -
    have "(P * A) $$ (i, j) =  (ia = 0..<m. Matrix.row P i $v ia * col A j $v ia)"
      unfolding times_mat_def scalar_prod_def using A P j i by auto
    also have "... = (ia = 0..<m. Matrix.row P i $v ia *  A $$ (ia,j))"
      by (rule sum.cong, insert A j, auto)
    also have "x dvd ..." using x by (meson atLeastLessThan_iff dvd_mult dvd_sum j)
    finally show ?thesis .
  qed
  thus ?thesis by auto
qed


lemma dvd_elements_mult_matrix_right:
  assumes A: "(A::'a::comm_ring_1 mat)  carrier_mat m n"
  and Q: "Q  carrier_mat n n"
  and x: "(i j. i<m  j<n  x dvd A$$(i,j))"
  shows "(i j. i<m  j<n  x dvd (A*Q)$$(i,j))"
proof -
  have "x dvd (A*Q) $$ (i, j)" if i: "i < m" and j: "j < n" for i j
  proof -
    have "(A*Q) $$ (i, j) =  (ia = 0..<n. Matrix.row A i $v ia * col Q j $v ia)"
      unfolding times_mat_def scalar_prod_def using A Q j i by auto
    also have "... = (ia = 0..<n. A $$ (i, ia) * col Q j $v ia)"
      by (rule sum.cong, insert A Q i, auto)
    also have "x dvd ..." using x
      by (meson atLeastLessThan_iff dvd_mult2 dvd_sum i)
    finally show ?thesis .
  qed
  thus ?thesis by auto
qed


lemma dvd_elements_mult_matrix_left_right:
  assumes A: "(A::'a::comm_ring_1 mat)  carrier_mat m n"
  and P: "P  carrier_mat m m"
  and Q: "Q  carrier_mat n n"
  and x: "(i j. i<m  j<n  x dvd A$$(i,j))"
shows "(i j. i<m  j<n  x dvd (P*A*Q)$$(i,j))"
  using dvd_elements_mult_matrix_left[OF A P x]
  by (meson P A Q dvd_elements_mult_matrix_right mult_carrier_mat)


definition append_cols :: "'a :: zero mat  'a mat  'a mat" (infixr "@c" 65)where
  "A @c B = four_block_mat A B (0m 0 (dim_col A)) (0m 0 (dim_col B))"

lemma append_cols_carrier[simp,intro]:
  "A  carrier_mat n a  B  carrier_mat n b  (A @c B)  carrier_mat n (a+b)"
  unfolding append_cols_def by auto

lemma append_cols_mult_left:
  assumes A: "A  carrier_mat n a"
  and B: "B  carrier_mat n b"
  and P: "P  carrier_mat n n"
shows "P * (A @c B) = (P*A) @c (P*B)"
proof -
  let ?P = "four_block_mat P (0m n 0) (0m 0 n) (0m 0 0)"
  have "P = ?P" by (rule eq_matI, auto)
  hence "P * (A @c B) = ?P * (A @c B)" by simp
  also have "?P * (A @c B) = four_block_mat (P * A + 0m n 0 * 0m 0 (dim_col A))
  (P * B + 0m n 0 * 0m 0 (dim_col B)) (0m 0 n * A + 0m 0 0 * 0m 0 (dim_col A))
  (0m 0 n * B + 0m 0 0 * 0m 0 (dim_col B))" unfolding append_cols_def
    by (rule mult_four_block_mat, insert A B P, auto)
  also have "... = four_block_mat (P * A) (P * B) (0m 0 (dim_col (P*A))) (0m 0 (dim_col (P*B)))"
    by (rule cong_four_block_mat, insert P, auto)
  also have "... = (P*A) @c (P*B)" unfolding append_cols_def by auto
  finally show ?thesis .
qed

lemma append_cols_mult_right_id:
  assumes A: "(A::'a::semiring_1 mat)  carrier_mat n 1"
  and B: "B  carrier_mat n (m-1)"
  and C: "C = four_block_mat (1m 1) (0m 1 (m - 1)) (0m (m - 1) 1) D"
  and D: "D  carrier_mat (m-1) (m-1)"
shows "(A @c B) * C = A @c (B * D)"
proof -
  let ?C = "four_block_mat (1m 1) (0m 1 (m - 1)) (0m (m - 1) 1) D"
  have "(A @c B) * C = (A @c B) * ?C" unfolding C by auto
  also have "... = four_block_mat A B (0m 0 (dim_col A)) (0m 0 (dim_col B)) * ?C"
    unfolding append_cols_def by auto
  also have "... = four_block_mat (A * 1m 1 + B * 0m (m - 1) 1) (A * 0m 1 (m - 1) + B * D)
    (0m 0 (dim_col A) * 1m 1 + 0m 0 (dim_col B) * 0m (m - 1) 1)
    (0m 0 (dim_col A) * 0m 1 (m - 1) + 0m 0 (dim_col B) * D)"
    by (rule mult_four_block_mat, insert assms, auto)
  also have "... = four_block_mat A (B * D) (0m 0 (dim_col A)) (0m 0 (dim_col (B*D)))"
    by (rule cong_four_block_mat, insert assms, auto)
  also have "... = A @c (B * D)" unfolding append_cols_def by auto
  finally show ?thesis .
qed


lemma append_cols_mult_right_id2:
 assumes A: "(A::'a::semiring_1 mat)  carrier_mat n a"
   and B: "B  carrier_mat n b"
   and C: "C = four_block_mat D (0m a b) (0m b a) (1m b)"
   and D: "D  carrier_mat a a"
shows "(A @c B) * C = (A * D) @c B"
proof -
  let ?C = "four_block_mat D (0m a b) (0m b a) (1m b)"
  have "(A @c B) * C = (A @c B) * ?C" unfolding C by auto
  also have "... = four_block_mat A B (0m 0 a) (0m 0 b) * ?C"
    unfolding append_cols_def using A B by auto
  also have "... = four_block_mat (A * D + B * 0m b a) (A * 0m a b + B * 1m b)
    (0m 0 a * D + 0m 0 b * 0m b a) (0m 0 a * 0m a b + 0m 0 b * 1m b)"
    by (rule mult_four_block_mat, insert A B C D, auto)
  also have "... = four_block_mat (A * D) B (0m 0 (dim_col (A*D))) (0m 0 (dim_col B))"
    by (rule cong_four_block_mat, insert assms, auto)
  also have "... = (A * D) @c B" unfolding append_cols_def by auto
  finally show ?thesis .
qed


lemma append_cols_nth:
  assumes A: "A  carrier_mat n a"
  and B: "B  carrier_mat n b"
  and i: "i<n" and j: "j < a + b"
shows "(A @c B) $$ (i, j) = (if j < dim_col A then A $$(i,j) else B$$(i,j-a))" (is "?lhs = ?rhs")
proof -
  let ?C = "(0m 0 (dim_col A))"
  let ?D = "(0m 0 (dim_col B))"
  have i2: "i < dim_row A + dim_row ?D" using i A by auto
  have j2: "j < dim_col A + dim_col (0m 0 (dim_col B))" using j B A by auto
  have "(A @c B) $$ (i, j) = four_block_mat A B ?C ?D $$ (i, j)"
    unfolding append_cols_def by auto
  also have "... = (if i < dim_row A then if j < dim_col A then A $$ (i, j)
  else B $$ (i, j - dim_col A) else if j < dim_col A then ?C $$ (i - dim_row A, j)
  else 0m 0 (dim_col B) $$ (i - dim_row A, j - dim_col A))"
    by (rule index_mat_four_block(1)[OF i2 j2])
  also have "... = ?rhs" using i A by auto
  finally show ?thesis .
qed

lemma append_cols_split:
  assumes d: "dim_col A > 0"
  shows "A = mat_of_cols (dim_row A) [col A 0] @c
             mat_of_cols (dim_row A) (map (col A) [1..<dim_col A])" (is "?lhs = ?A1 @c ?A2")
proof (rule eq_matI)
  fix i j assume i: "i < dim_row (?A1 @c ?A2)" and j: "j < dim_col (?A1 @c ?A2)"
  have "(?A1 @c ?A2) $$ (i, j) = (if j < dim_col ?A1 then ?A1 $$(i,j) else ?A2$$(i,j-(dim_col ?A1)))"
    by (rule append_cols_nth, insert i j, auto simp add: append_cols_def)
  also have "... = A $$ (i,j)"
  proof (cases "j< dim_col ?A1")
    case True
    then show ?thesis
      by (metis One_nat_def Suc_eq_plus1 add.right_neutral append_cols_def col_def i
          index_mat_four_block(2) index_vec index_zero_mat(2) less_one list.size(3) list.size(4)
          mat_of_cols_Cons_index_0 mat_of_cols_carrier(2) mat_of_cols_carrier(3))
  next
    case False
    then show ?thesis
      by (metis (no_types, lifting) Suc_eq_plus1 Suc_less_eq Suc_pred add_diff_cancel_right' append_cols_def
          diff_zero i index_col index_mat_four_block(2) index_mat_four_block(3) index_zero_mat(2)
          index_zero_mat(3) j length_map length_upt linordered_semidom_class.add_diff_inverse list.size(3)
          list.size(4) mat_of_cols_carrier(2) mat_of_cols_carrier(3) mat_of_cols_index nth_map_upt
          plus_1_eq_Suc upt_0)
  qed
  finally show "A $$ (i, j) = (?A1 @c ?A2) $$ (i, j)" ..
qed (auto simp add: append_cols_def d)


lemma append_rows_nth:
  assumes A: "A  carrier_mat a n"
  and B: "B  carrier_mat b n"
  and i: "i<a+b" and j: "j < n"
shows "(A @r B) $$ (i, j) = (if i < dim_row A then A $$(i,j) else B$$(i-a,j))" (is "?lhs = ?rhs")
proof -
  let ?C = "(0m (dim_row A) 0)"
  let ?D = "(0m (dim_row B) 0)"
  have i2: "i < dim_row A + dim_row ?D" using i j A B by auto
  have j2: "j < dim_col A + dim_col ?D" using i j A B by auto
  have "(A @r B) $$ (i, j) = four_block_mat A ?C B ?D $$ (i, j)"
    unfolding append_rows_def by auto
  also have "... =  (if i < dim_row A then if j < dim_col A then A $$ (i, j) else ?C $$ (i, j - dim_col A)
   else if j < dim_col A then B $$ (i - dim_row A, j) else ?D $$ (i - dim_row A, j - dim_col A))"
    by (rule index_mat_four_block(1)[OF i2 j2])
  also have "... = ?rhs" using i A j B by auto
  finally show ?thesis .
qed

lemma append_rows_split:
  assumes k: "kdim_row A"
  shows "A = (mat_of_rows (dim_col A) [Matrix.row A i. i  [0..<k]]) @r
             (mat_of_rows (dim_col A) [Matrix.row A i. i  [k..<dim_row A]])" (is "?lhs = ?A1 @r ?A2")
proof (rule eq_matI)
  have "(?A1 @r ?A2)  carrier_mat (k + (dim_row A-k)) (dim_col A)"
    by (rule carrier_append_rows, insert k, auto)
  hence A1_A2: "(?A1 @r ?A2)  carrier_mat (dim_row A) (dim_col A)" using k by simp
  thus "dim_row A = dim_row (?A1 @r ?A2)" and "dim_col A = dim_col (?A1 @r ?A2)" by auto
  fix i j assume i: "i < dim_row (?A1 @r ?A2)" and j: "j < dim_col (?A1 @r ?A2)"
  have "(?A1 @r ?A2) $$ (i, j) = (if i < dim_row ?A1 then ?A1 $$(i,j) else ?A2$$(i-(dim_row ?A1),j))"
    by (rule append_rows_nth, insert k i j, auto simp add: append_rows_def)
  also have "... = A $$ (i,j)"
  proof (cases "i<dim_row ?A1")
    case True
    then show ?thesis
      by (metis (no_types, lifting) Matrix.row_def add.left_neutral add.right_neutral append_rows_def
          index_mat(1) index_mat_four_block(3) index_vec index_zero_mat(3) j length_map length_upt
          mat_of_rows_carrier(2,3) mat_of_rows_def nth_map_upt prod.simps(2))
  next
    case False
    let ?xs = "(map (Matrix.row A) [k..<dim_row A])"
    have dim_row_A1: "dim_row ?A1 = k" by auto
    have "?A2 $$ (i-k,j) = ?xs ! (i-k) $v j"
      by (rule mat_of_rows_index, insert i k False A1_A2 j, auto)
    also have "... = A $$ (i,j)" using A1_A2 False i j by auto
    finally show ?thesis using A1_A2 False i j by auto
  qed
  finally show " A $$ (i, j) = (?A1 @r ?A2) $$ (i,j)" by simp
qed



lemma transpose_mat_append_rows:
 assumes A: "A  carrier_mat a n" and B: "B  carrier_mat b n"
 shows "(A @r B)T = AT @c BT"
  by (smt append_cols_def append_rows_def A B carrier_matD(1) index_transpose_mat(3)
      transpose_four_block_mat zero_carrier_mat zero_transpose_mat)

lemma transpose_mat_append_cols:
 assumes A: "A  carrier_mat n a" and B: "B  carrier_mat n b"
 shows "(A @c B)T = AT @r BT"
  by (metis Matrix.transpose_transpose A B carrier_matD(1) carrier_mat_triv
      index_transpose_mat(3) transpose_mat_append_rows)


lemma append_rows_mult_right:
  assumes A: "(A::'a::comm_semiring_1 mat)  carrier_mat a n" and B: "B  carrier_mat b n"
    and Q: "Q carrier_mat n n"
  shows "(A @r B) * Q = (A * Q) @r (B*Q)"
proof -
  have "transpose_mat ((A @r B) * Q) = QT * (A @r B)T"
    by (rule transpose_mult, insert A B Q, auto)
  also have "... = QT * (AT @c BT)" using transpose_mat_append_rows assms by metis
  also have "... = QT * AT @c QT * BT"
    using append_cols_mult_left assms by (metis transpose_carrier_mat)
  also have "transpose_mat ... = (A * Q) @r (B*Q)"
    by (smt A B Matrix.transpose_mult Matrix.transpose_transpose append_cols_def append_rows_def Q
        carrier_mat_triv index_mult_mat(2) index_transpose_mat(2) transpose_four_block_mat
        zero_carrier_mat zero_transpose_mat)
  finally show ?thesis by simp
qed

lemma append_rows_mult_left_id:
  assumes A: "(A::'a::comm_semiring_1 mat)  carrier_mat 1 n"
  and B: "B  carrier_mat (m-1) n"
  and C: "C = four_block_mat (1m 1) (0m 1 (m - 1)) (0m (m - 1) 1) D"
  and D: "D  carrier_mat (m-1) (m-1)"
shows "C * (A @r B) = A @r (D * B)"
proof -
  have "transpose_mat (C * (A @r B)) = (A @r B)T * CT"
    by (metis (no_types, lifting) B C D Matrix.transpose_mult append_rows_def A carrier_matD
        carrier_mat_triv index_mat_four_block(2,3) index_zero_mat(2) one_carrier_mat)
  also have "... = (AT @c BT) * CT" using transpose_mat_append_rows[OF A B] by auto
  also have "... = AT @c (BT * DT)" by (rule append_cols_mult_right_id, insert A B C D, auto)
  also have "transpose_mat ... = A @r (D * B)"
    by (smt B D Matrix.transpose_mult Matrix.transpose_transpose append_cols_def append_rows_def A
        carrier_matD(2) carrier_mat_triv index_mult_mat(3) index_transpose_mat(3)
        transpose_four_block_mat zero_carrier_mat zero_transpose_mat)
  finally show ?thesis by auto
qed

lemma append_rows_mult_left_id2:
 assumes A: "(A::'a::comm_semiring_1 mat)  carrier_mat a n"
   and B: "B  carrier_mat b n"
   and C: "C = four_block_mat D (0m a b) (0m b a) (1m b)"
   and D: "D  carrier_mat a a"
 shows "C * (A @r B) = (D * A) @r B"
proof -
  have "(C * (A @r B))T = (A @r B)T * CT" by (rule transpose_mult, insert assms, auto)
  also have "... = (AT @c BT) * CT" by (metis A B transpose_mat_append_rows)
  also have "... = (AT * DT @c BT)" by (rule append_cols_mult_right_id2, insert assms, auto)
  also have "...T = (D * A) @r B"
    by (metis A B D transpose_mult transpose_transpose mult_carrier_mat transpose_mat_append_rows)
  finally show ?thesis by simp
qed

lemma four_block_mat_preserves_column:
  assumes A: "(A::'a::semiring_1 mat)  carrier_mat n m"
    and B: "B = four_block_mat (1m 1) (0m 1 (m - 1)) (0m (m - 1) 1) C"
  and C: "C  carrier_mat (m-1) (m-1)"
  and i: "i<n" and m: "0<m"
shows "(A*B) $$ (i,0) = A $$ (i,0)"
proof -
  let ?A1 = "mat_of_cols n [col A 0]"
  let ?A2 = "mat_of_cols n (map (col A) [1..<dim_col A])"
  have n2: "dim_row A = n" using A by auto
  have "A = ?A1 @c ?A2" by (rule append_cols_split[of A, unfolded n2], insert m A, auto)
  hence "A * B = (?A1 @c ?A2) * B" by simp
  also have "... = ?A1 @c (?A2 * C)" by (rule append_cols_mult_right_id[OF _ _ B C], insert A, auto)
  also have "... $$ (i,0) = ?A1 $$ (i,0)" using append_cols_nth by (simp add: append_cols_def i)
  also have "... = A $$ (i,0)"
    by (metis A i carrier_matD(1) col_def index_vec mat_of_cols_Cons_index_0)
  finally show ?thesis .
qed


definition "lower_triangular A = (i j. i < j  i < dim_row A  j < dim_col A  A $$ (i,j) = 0)"

lemma lower_triangular_index:
  assumes "lower_triangular A" "i<j" "i < dim_row A" "j < dim_col A"
  shows "A $$ (i,j) = 0"
  using assms unfolding lower_triangular_def by auto

lemma commute_multiples_identity:
  assumes A: "(A::'a::comm_ring_1 mat)  carrier_mat n n"
  shows "A * (k m (1m n)) = (k m (1m n)) * A"
proof -
  have "(ia = 0..<n. A $$ (i, ia) * (k * (if ia = j then 1 else 0)))
    = (ia = 0..<n. k * (if i = ia then 1 else 0) * A $$ (ia, j))" (is "?lhs=?rhs")
    if i: "i<n" and j: "j<n" for i j
  proof -
    let ?f = "λia. A $$ (i, ia) * (k * (if ia = j then 1 else 0))"
    let ?g = "λia. k * (if i = ia then 1 else 0) * A $$ (ia, j)"
    have rw0: "(ia  ({0..<n}-{j}). ?f ia) = 0" by (rule sum.neutral, auto)
    have rw0': "(ia  ({0..<n}-{i}). ?g ia) = 0" by (rule sum.neutral, auto)
    have "?lhs = ?f j + (ia  ({0..<n}-{j}). ?f ia)"
      by (smt atLeast0LessThan finite_atLeastLessThan lessThan_iff sum.remove j)
    also have "... = A $$ (i, j) * k" using rw0 by auto
    also have "... = ?g i + (ia  ({0..<n}-{i}). ?g ia)" using rw0' by auto
    also have "... = ?rhs"
      by (smt atLeast0LessThan finite_atLeastLessThan lessThan_iff sum.remove i)
    finally show ?thesis .
  qed
  thus ?thesis using A
  unfolding times_mat_def scalar_prod_def
  by auto (rule eq_matI, auto, smt sum.cong)
qed

(*This lemma is obtained using Mod_Type_Connect, otherwise we cannot prove HMA_I 0 0.
The lelma could also be obtained with no use of transfer rules, proving it directly.*)
lemma det_2:
  assumes A: "A  carrier_mat 2 2"
  shows "Determinant.det A = A$$(0,0) * A $$ (1,1) - A$$(0,1)*A$$(1,0)"
proof -
  let ?A = "(Mod_Type_Connect.to_hmam A)::'a^2^2"
  have [transfer_rule]: "Mod_Type_Connect.HMA_M A ?A"
    unfolding Mod_Type_Connect.HMA_M_def using from_hma_to_hmam A by auto
  have [transfer_rule]: "Mod_Type_Connect.HMA_I 0 0"
    unfolding Mod_Type_Connect.HMA_I_def by (simp add: to_nat_0)
  have [transfer_rule]: "Mod_Type_Connect.HMA_I 1 1"
    unfolding Mod_Type_Connect.HMA_I_def by (simp add: to_nat_1)
  have "Determinant.det A = Determinants.det ?A" by (transfer, simp)
  also have "... = ?A $h 1 $h 1 * ?A $h 2 $h 2 - ?A $h 1 $h 2 * ?A $h 2 $h 1" unfolding det_2 by simp
  also have "... = ?A $h 0 $h 0 * ?A $h 1 $h 1 - ?A $h 0 $h 1 * ?A $h 1 $h 0"
    by (smt Groups.mult_ac(2) exhaust_2 semiring_norm(160))
  also have "... = A$$(0,0) * A $$ (1,1) - A$$(0,1)*A$$(1,0)"
    unfolding index_hma_def[symmetric] by (transfer, auto)
  finally show ?thesis .
qed

lemma mat_diag_smult: "mat_diag n (λ x. (k::'a::comm_ring_1)) = (k m 1m n)"
proof -
  have "mat_diag n (λ x. k) = mat_diag n (λ x. k * 1)" by auto
  also have "... = mat_diag n (λ x. k) * mat_diag n (λ x. 1)" using mat_diag_diag
    by (simp add: mat_diag_def)
  also have "... = mat_diag n (λ x. k) * (1m n)" by auto  thm mat_diag_mult_left
  also have "... = Matrix.mat n n (λ(i, j). k * (1m n) $$ (i, j))" by (rule mat_diag_mult_left, auto)
  also have "... = (k m 1m n)" unfolding smult_mat_def by auto
  finally show ?thesis .
qed

lemma invertible_mat_four_block_mat_lower_right:
  assumes A: "(A::'a::comm_ring_1 mat)  carrier_mat n n" and inv_A: "invertible_mat A"
  shows "invertible_mat (four_block_mat (1m 1) (0m 1 n) (0m n 1) A)"
proof -
  let ?I = "(four_block_mat (1m 1) (0m 1 n) (0m n 1) A)"
  have "Determinant.det ?I = Determinant.det (1m 1) * Determinant.det A"
    by (rule det_four_block_mat_lower_left_zero_col, insert assms, auto)
  also have "... = Determinant.det A" by auto
  finally have "Determinant.det ?I = Determinant.det A" .
  thus ?thesis
    by (metis (no_types, lifting) assms carrier_matD(1) carrier_matD(2) carrier_mat_triv
        index_mat_four_block(2) index_mat_four_block(3) index_one_mat(2) index_one_mat(3)
        invertible_iff_is_unit_JNF)
qed


lemma invertible_mat_four_block_mat_lower_right_id:
  assumes A: "(A::'a::comm_ring_1 mat)  carrier_mat m m" and B: "B = 0m m (n-m)" and C: "C = 0m (n-m) m"
    and D: "D = 1m (n-m)" and "n>m" and inv_A: "invertible_mat A"
  shows "invertible_mat (four_block_mat A B C D)"
proof -
  have "Determinant.det (four_block_mat A B C D) = Determinant.det A"
    by (rule det_four_block_mat_lower_right_id, insert assms, auto)
  thus ?thesis using inv_A
    by (metis (no_types, lifting) assms(1) assms(4) carrier_matD(1) carrier_matD(2) carrier_mat_triv
        index_mat_four_block(2) index_mat_four_block(3) index_one_mat(2) index_one_mat(3)
        invertible_iff_is_unit_JNF)
qed

lemma split_block4_decreases_dim_row:
  assumes E: "(A,B,C,D) = split_block E 1 1"
    and E1: "dim_row E > 1" and E2: "dim_col E > 1"
  shows "dim_row D < dim_row E"
proof -
  have "D  carrier_mat (1 + (dim_row E - 2)) (1 + (dim_col E - 2))"
    by (rule split_block(4)[OF E[symmetric]], insert E1 E2, auto)
  hence "D  carrier_mat (dim_row E - 1) (dim_col E - 1)" using E1 E2 by auto
  thus ?thesis using E1 by auto
qed


lemma inv_P'PAQQ':
  assumes A: "A  carrier_mat n n"
    and P: "P  carrier_mat n n"
    and inv_P: "inverts_mat P' P"
    and inv_Q: "inverts_mat Q Q'"
    and Q: "Q  carrier_mat n n"
    and P': "P'  carrier_mat n n"
    and Q': "Q'  carrier_mat n n"
shows  "(P'*(P*A*Q)*Q') = A"
proof -
  have "(P'*(P*A*Q)*Q') = (P'*(P*A*Q*Q'))"
    by (smt P P' Q Q' assoc_mult_mat carrier_matD(1) carrier_matD(2) carrier_mat_triv
        index_mult_mat(2) index_mult_mat(3))
  also have "... = ((P'*P)*A*(Q*Q'))"
    by (smt A P P' Q Q' assoc_mult_mat carrier_matD(1) carrier_matD(2) carrier_mat_triv
        index_mult_mat(3) inv_Q inverts_mat_def right_mult_one_mat')
  finally show ?thesis
    by (metis P' Q A inv_P inv_Q carrier_matD(1) inverts_mat_def
        left_mult_one_mat right_mult_one_mat)
qed

lemma
  assumes "U  carrier_mat 2 2" and "V  carrier_mat 2 2" and "A = U * V"
shows mat_mult2_00: "A $$ (0,0) = U $$ (0,0)*V $$ (0,0) + U $$ (0,1)*V $$ (1,0)"
  and mat_mult2_01: "A $$ (0,1) = U $$ (0,0)*V $$ (0,1) + U $$ (0,1)*V $$ (1,1)"
  and mat_mult2_10: "A $$ (1,0) = U $$ (1,0)*V $$ (0,0) + U $$ (1,1)*V $$ (1,0)"
  and mat_mult2_11: "A $$ (1,1) = U $$ (1,0)*V $$ (0,1) + U $$ (1,1)*V $$ (1,1)"
    using assms unfolding times_mat_def Matrix.row_def col_def scalar_prod_def
    using sum_two_rw by auto


subsection‹Lemmas about @{text "sorted lists"}, @{text "insort"} and @{text "pick"}


lemma sorted_distinct_imp_sorted_wrt:
  assumes "sorted xs" and "distinct xs"
  shows "sorted_wrt (<) xs"
  using assms
  by (induct xs, insert le_neq_trans, auto)


lemma sorted_map_strict:
  assumes "strict_mono_on g {0..<n}"
  shows "sorted (map g [0..<n])"
  using assms
  by (induct n, auto simp add: sorted_append strict_mono_on_def less_imp_le)


lemma sorted_list_of_set_map_strict:
  assumes "strict_mono_on g {0..<n}"
  shows "sorted_list_of_set (g ` {0..<n}) = map g [0..<n]"
  using assms
  proof (induct n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  note sg = Suc.prems
  have sg_n: "strict_mono_on g {0..<n}" using sg unfolding strict_mono_on_def by auto
  have g_image_rw: "g ` {0..<Suc n} = insert (g n) (g ` {0..<n})"
    by (simp add: set_upt_Suc)
  have "sorted_list_of_set (g ` {0..<Suc n}) = sorted_list_of_set (insert (g n) (g ` {0..<n}))"
    using g_image_rw by simp
  also have "... = insort (g n) (sorted_list_of_set (g ` {0..<n}))"
  proof (rule sorted_list_of_set.insert)
    have "inj_on g {0..<Suc n}" using sg strict_mono_on_imp_inj_on by blast
    thus "g n  g ` {0..<n}" unfolding inj_on_def by fastforce
  qed (simp)
  also have "... = insort (g n) (map g [0..<n])"
    using Suc.hyps sg unfolding strict_mono_on_def by auto
  also have "... = map g [0..<Suc n]"
  proof (simp, rule sorted_insort_is_snoc)
    show "sorted (map g [0..<n])" by (rule sorted_map_strict[OF sg_n])
    show "xset (map g [0..<n]). x  g n" using sg unfolding strict_mono_on_def
      by (simp add: less_imp_le)
  qed
  finally show ?case .
qed


lemma sorted_nth_strict_mono:
  "sorted xs  distinct xs i < j  j < length xs  xs!i < xs!j"
  by (simp add: less_le nth_eq_iff_index_eq sorted_iff_nth_mono_less)


lemma sorted_list_of_set_0_LEAST:
  assumes finI: "finite I" and I: "I  {}"
  shows "sorted_list_of_set I ! 0 = (LEAST n. nI)"
proof (rule Least_equality[symmetric])
  show "sorted_list_of_set I ! 0  I"
    by (metis I Max_in finI gr_zeroI in_set_conv_nth not_less_zero set_sorted_list_of_set)
  fix y assume "y  I"
  thus "sorted_list_of_set I ! 0  y"
    by (metis eq_iff finI in_set_conv_nth neq0_conv sorted_iff_nth_mono_less
        sorted_list_of_set(1) sorted_sorted_list_of_set)
qed

lemma sorted_list_of_set_eq_pick:
  assumes i: "i < length (sorted_list_of_set I)"
  shows "sorted_list_of_set I ! i = pick I i"
proof -
  have finI: "finite I"
  proof (rule ccontr)
    assume "infinite I"
    hence "length (sorted_list_of_set I) = 0" using sorted_list_of_set.infinite by auto
    thus False using i by simp
  qed
  show ?thesis
  using i
proof (induct i)
  case 0
  have I: "I  {}" using "0.prems" sorted_list_of_set_empty by blast
  show ?case unfolding pick.simps by (rule sorted_list_of_set_0_LEAST[OF finI I])
next
  case (Suc i)
  note x_less = Suc.prems
  show ?case
  proof (unfold pick.simps, rule Least_equality[symmetric], rule conjI)
    show 1: "pick I i < sorted_list_of_set I ! Suc i"
      by (metis Suc.hyps Suc.prems Suc_lessD distinct_sorted_list_of_set find_first_unique lessI
          nat_less_le sorted_sorted_list_of_set sorted_sorted_wrt sorted_wrt_nth_less)
    show "sorted_list_of_set I ! Suc i  I"
      using Suc.prems finI nth_mem set_sorted_list_of_set by blast
    have rw: "sorted_list_of_set I ! i = pick I i"
      using Suc.hyps Suc_lessD x_less by blast
    have sorted_less: "sorted_list_of_set I ! i < sorted_list_of_set I ! Suc i"
      by (simp add: 1 rw)
    fix y assume y: "y  I  pick I i < y"
    show "sorted_list_of_set I ! Suc i  y"
      by (smt antisym_conv finI in_set_conv_nth less_Suc_eq less_Suc_eq_le nat_neq_iff rw
          sorted_iff_nth_mono_less sorted_list_of_set(1) sorted_sorted_list_of_set x_less y)
  qed
qed
qed

text‹$b$ is the position where we add, $a$ the element to be added and $i$ the position
  that is checked›

lemma insort_nth':
  assumes "j<b. xs ! j < a" and "sorted xs" and "a  set xs"
    and "i < length xs + 1" and "i < b"
    and "xs  []" and "b < length xs"
  shows "insort a xs ! i = xs ! i"
  using assms
proof (induct xs arbitrary: a b i)
  case Nil
  then show ?case by auto
next
  case (Cons x xs)
  note less = Cons.prems(1)
  note sorted = Cons.prems(2)
  note a_notin = Cons.prems(3)
  note i_length = Cons.prems(4)
  note i_b = Cons.prems(5)
  note b_length = Cons.prems(7)
  show ?case
  proof (cases "a  x")
    case True
    have "insort a (x # xs) ! i = (a # x # xs) ! i" using True by simp
    also have "... =  (x # xs) ! i"
      using Cons.prems(1) Cons.prems(5) True by force
    finally show ?thesis .
  next
    case False note x_less_a = False
    have "insort a (x # xs) ! i = (x # insort a xs) ! i" using False by simp
    also have "... = (x # xs) ! i"
    proof (cases "i = 0")
      case True
      then show ?thesis by auto
    next
      case False
      have "(x # insort a xs) ! i = (insort a xs) ! (i-1)"
        by (simp add: False nth_Cons')
      also have "... = xs ! (i-1)"
      proof (rule Cons.hyps)
        show "sorted xs" using sorted by simp
        show "a  set xs" using a_notin by simp
        show "i - 1 < length xs + 1" using i_length False by auto
        show "xs  []" using i_b b_length by force
        show "i - 1 < b - 1" by (simp add: False diff_less_mono i_b leI)
        show "b - 1 < length xs" using b_length i_b by auto
        show "j<b - 1. xs ! j < a" using less less_diff_conv by auto
      qed
      also have "... = (x # xs) ! i" by (simp add: False nth_Cons')
      finally show ?thesis .
    qed
    finally show ?thesis .
  qed
qed


lemma insort_nth:
  assumes  "sorted xs" and "a  set xs"
    and "i < index (insort a xs) a"
    and "xs  []"
  shows "insort a xs ! i = xs ! i"
  using assms
proof (induct xs arbitrary: a i)
case Nil
  then show ?case by auto
next
  case (Cons x xs)
  note sorted = Cons.prems(1)
  note a_notin = Cons.prems(2)
  note i_index = Cons.prems(3)
  show ?case
  proof (cases "a  x")
    case True
    have "insort a (x # xs) ! i = (a # x # xs) ! i" using True by simp
    also have "... = (x # xs) ! i"
      using Cons.prems(1) Cons.prems(3) True by force
    finally show ?thesis .
  next
    case False note x_less_a = False
    show ?thesis
    proof (cases "xs = []")
      case True
      have "x  a" using False by auto
      then show ?thesis  using True i_index False by auto
    next
      case False note xs_not_empty = False
      have "insort a (x # xs) ! i = (x # insort a xs) ! i" using x_less_a by simp
      also have "... = (x # xs) ! i"
      proof (cases "i = 0")
        case True
        then show ?thesis by auto
      next
        case False note i0 = False
        have "(x # insort a xs) ! i = (insort a xs) ! (i-1)"
          by (simp add: False nth_Cons')
        also have "... = xs ! (i-1)"
        proof (rule Cons.hyps[OF _ _ _ xs_not_empty])
          show "sorted xs" using sorted by simp
          show "a  set xs" using a_notin by simp
          have "index (insort a (x # xs)) a = index ((x # insort a xs)) a"
            using x_less_a by auto
          also have "... = index (insort a xs) a + 1"
            unfolding index_Cons using x_less_a by simp
          finally show "i - 1 < index (insort a xs) a" using False i_index by linarith
        qed
        also have "... = (x # xs) ! i" by (simp add: False nth_Cons')
        finally show ?thesis .
      qed
      finally show ?thesis .
    qed
  qed
qed

lemma insort_nth2:
  assumes "sorted xs" and "a  set xs"
    and "i < length xs" and "i  index (insort a xs) a"
    and "xs  []"
  shows "insort a xs ! (Suc i) = xs ! i"
  using assms
proof (induct xs arbitrary: a i)
  case Nil
  then show ?case by auto
next
  case (Cons x xs)
  note sorted = Cons.prems(1)
  note a_notin = Cons.prems(2)
  note i_length = Cons.prems(3)
  note index_i = Cons.prems(4)
  show ?case
  proof (cases "a  x")
    case True
    have "insort a (x # xs) ! (Suc i) = (a # x # xs) ! (Suc i)" using True by simp
    also have "... =  (x # xs) ! i"
      using Cons.prems(1) Cons.prems(5) True by force
    finally show ?thesis .
  next
    case False note x_less_a = False
    have "insort a (x # xs) ! (Suc i) = (x # insort a xs) ! (Suc i)" using False by simp
    also have "... = (x # xs) ! i"
    proof (cases "i = 0")
        case True
        then show ?thesis using index_i linear x_less_a by fastforce
      next
        case False note i0 = False
        show ?thesis
        proof -
          have Suc_i: "Suc (i - 1) = i"
            using i0 by auto
          have "(x # insort a xs) ! (Suc i) = (insort a xs) ! i"
            by (simp add: nth_Cons')
          also have "... = (insort a xs) ! Suc (i - 1)" using Suc_i by simp
          also have "... = xs ! (i - 1)"
          proof (rule Cons.hyps)
            show "sorted xs" using sorted by simp
            show "a  set xs" using a_notin by simp
            show "i - 1 < length xs" using i_length using Suc_i by auto
            thus "xs  []" by auto
            have "index (insort a (x # xs)) a = index ((x # insort a xs)) a" using x_less_a by simp
            also have "... = index (insort a xs) a + 1" unfolding index_Cons using x_less_a by simp
            finally show "index (insort a xs) a  i - 1" using index_i i0 by auto
          qed
          also have "... = (x # xs) ! i" using Suc_i by auto
          finally show ?thesis .
        qed
      qed
      finally show ?thesis .
    qed
qed

lemma pick_index:
  assumes a: "a  I" and a'_card: "a' < card I"
  shows "(pick I a' = a) = (index (sorted_list_of_set I) a = a')"
proof -
  have finI: "finite I" using a'_card card.infinite by force
  have length_I: "length (sorted_list_of_set I) = card I"
    by (metis a'_card card.infinite distinct_card distinct_sorted_list_of_set
        not_less_zero set_sorted_list_of_set)
  let ?i = "index (sorted_list_of_set I) a"
  have "(sorted_list_of_set I) ! a' = pick I a'"
    by (rule sorted_list_of_set_eq_pick, auto simp add: finI a'_card length_I)
  moreover have "(sorted_list_of_set I) ! ?i = a"
    by (rule nth_index, simp add: a finI)
  ultimately show ?thesis
    by (metis a'_card distinct_sorted_list_of_set index_nth_id length_I)
qed

end

Theory Cauchy_Binet

(*
    Author:      Jose Divasón
    Email:       jose.divason@unirioja.es
*)

section ‹The Cauchy--Binet formula›

theory Cauchy_Binet
  imports
  Diagonal_To_Smith
  SNF_Missing_Lemmas
begin

subsection ‹Previous missing results about @{text "pick"} and @{text "insert"}

lemma pick_insert:
  assumes a_notin_I: "a  I" and i2: "i < card I"
    and a_def: "pick (insert a I) a' = a" (*Alternative: index (insort a (sorted_list_of_set I)) a = a'*)
    and ia': "i < a'" (*Case 1*)
    and a'_card: "a' < card I + 1"
  shows "pick (insert a I) i = pick I i"
proof -
  have finI: "finite I"
    using i2
    using card.infinite by force
  have "pick (insert a I) i = sorted_list_of_set (insert a I) ! i"
  proof (rule sorted_list_of_set_eq_pick[symmetric])
    have "finite (insert a I)"
      using card.infinite i2 by force
    thus "i < length (sorted_list_of_set (insert a I))"
      by (metis a_notin_I card_insert_disjoint distinct_card finite_insert
          i2 less_Suc_eq sorted_list_of_set(1) sorted_list_of_set(3))
  qed
  also have "... = insort a (sorted_list_of_set I) ! i"
    using sorted_list_of_set.insert
    by (metis a_notin_I card.infinite i2 not_less0)
  also have "... = (sorted_list_of_set I) ! i"
  proof (rule insort_nth[OF])
     show "sorted (sorted_list_of_set I)" by auto
     show "a  set (sorted_list_of_set I)" using a_notin_I
       by (metis card.infinite i2 not_less_zero set_sorted_list_of_set)
     have "index (sorted_list_of_set (insert a I)) a = a'"
       using pick_index a_def
       using a'_card a_notin_I finI by auto
     hence "index (insort a (sorted_list_of_set I)) a = a'"
       by (simp add: a_notin_I finI)
     thus "i < index (insort a (sorted_list_of_set I)) a" using ia' by auto
     show "sorted_list_of_set I  []" using finI i2 by fastforce
   qed
  also have "... = pick I i"
  proof (rule sorted_list_of_set_eq_pick)
    have "finite I" using card.infinite i2 by fastforce
    thus "i < length (sorted_list_of_set I)"
      by (metis distinct_card distinct_sorted_list_of_set i2 set_sorted_list_of_set)
  qed
  finally show ?thesis .
qed


lemma pick_insert2:
  assumes a_notin_I: "a  I" and i2: "i < card I"
    and a_def: "pick (insert a I) a' = a" (*Alternative: index (sorted_list_of_set (insert a I)) a = a'*)
    and ia': "i  a'" (*Case 2*)
    and a'_card: "a' < card I + 1"
  shows "pick (insert a I) i < pick I i"
proof (cases "i = 0")
  case True
  then show ?thesis
    by (auto, metis (mono_tags, lifting) DL_Missing_Sublist.pick.simps(1) Least_le a_def a_notin_I
        dual_order.order_iff_strict i2 ia' insertCI le_zero_eq not_less_Least pick_in_set_le)
next
  case False
  hence i0: "i = Suc (i - 1)" using a'_card ia' by auto
  have finI: "finite I"
    using i2 card.infinite by force
  have index_a'1: "index (sorted_list_of_set (insert a I)) a = a'"
    using pick_index
    using a'_card a_def a_notin_I finI by auto
  hence index_a': "index (insort a (sorted_list_of_set I)) a = a'"
    by (simp add: a_notin_I finI)
  have i1_length: "i - 1 < length (sorted_list_of_set I)" using i2
    by (metis distinct_card distinct_sorted_list_of_set finI
        less_imp_diff_less set_sorted_list_of_set)
  have 1: "pick (insert a I) i = sorted_list_of_set (insert a I) ! i"
  proof (rule sorted_list_of_set_eq_pick[symmetric])
    have "finite (insert a I)"
      using card.infinite i2 by force
    thus "i < length (sorted_list_of_set (insert a I))"
      by (metis a_notin_I card_insert_disjoint distinct_card finite_insert
          i2 less_Suc_eq sorted_list_of_set(1) sorted_list_of_set(3))
  qed
  also have 2: "... = insort a (sorted_list_of_set I) ! i"
    using sorted_list_of_set.insert
    by (metis a_notin_I card.infinite i2 not_less0)
  also have "... = insort a (sorted_list_of_set I) ! Suc (i-1)" using i0 by auto
  also have "... < pick I i"
  proof (cases "i = a'")
    case True
    have "(sorted_list_of_set I) ! i > a"
      by (smt "1" Suc_less_eq True a_def a_notin_I distinct_card distinct_sorted_list_of_set finI i2
          ia' index_a' insort_nth2 length_insort lessI list.size(3) nat_less_le not_less_zero
          pick_in_set_le set_sorted_list_of_set sorted_list_of_set(2) sorted_list_of_set.insert
          sorted_list_of_set_eq_pick sorted_sorted_wrt sorted_wrt_nth_less)
    moreover have "a = insort a (sorted_list_of_set I) ! i" using True 1 2 a_def by auto
    ultimately show ?thesis using 1 2
      by (metis distinct_card finI i0 i2 set_sorted_list_of_set
          sorted_list_of_set(3) sorted_list_of_set_eq_pick)
  next
    case False
    have "insort a (sorted_list_of_set I) ! Suc (i-1) = (sorted_list_of_set I) ! (i-1)"
      by (rule insort_nth2, insert i1_length False ia' index_a', auto simp add: a_notin_I finI)
    also have "... = pick I (i-1)"
      by (rule sorted_list_of_set_eq_pick[OF i1_length])
    also have "... < pick I i" using i0 i2 pick_mono_le by auto
    finally show ?thesis .
  qed
  finally show ?thesis .
qed

lemma pick_insert3:
  assumes a_notin_I: "a  I" and i2: "i < card I"
    and a_def: "pick (insert a I) a' = a" (*Alternative: index (sorted_list_of_set (insert a I)) a = a'.*)
    and ia': "i  a'" (*Case 2*)
    and a'_card: "a' < card I + 1"
  shows "pick (insert a I) (Suc i) = pick I i"
proof (cases "i = 0")
  case True
  have a_LEAST: "a < (LEAST aa. aaI)"
    using True a_def a_notin_I i2 ia' pick_insert2 by fastforce
  have Least_rw: "(LEAST aa. aa = a  aa  I) = a"
    by (rule Least_equality, insert a_notin_I, auto,
        metis a_LEAST le_less_trans nat_le_linear not_less_Least)
  let ?P = "λaa. (aa = a  aa  I)  (LEAST aa. aa = a  aa  I) < aa"
  let ?Q = "λaa. aa  I"
  have "?P = ?Q" unfolding Least_rw fun_eq_iff
    by (auto, metis a_LEAST le_less_trans not_le not_less_Least)
  thus ?thesis using True by auto
next
  case False
  have finI: "finite I"
    using i2 card.infinite by force
  have index_a'1: "index (sorted_list_of_set (insert a I)) a = a'"
    using pick_index
    using a'_card a_def a_notin_I finI by auto
  hence index_a': "index (insort a (sorted_list_of_set I)) a = a'"
    by (simp add: a_notin_I finI)
  have i1_length: "i < length (sorted_list_of_set I)" using i2
    by (metis distinct_card distinct_sorted_list_of_set finI set_sorted_list_of_set)
  have 1: "pick (insert a I) (Suc i) = sorted_list_of_set (insert a I) ! (Suc i)"
  proof (rule sorted_list_of_set_eq_pick[symmetric])
    have "finite (insert a I)"
      using card.infinite i2 by force
    thus "Suc i < length (sorted_list_of_set (insert a I))"
      by (metis Suc_mono a_notin_I card_insert_disjoint distinct_card distinct_sorted_list_of_set
          finI i2 set_sorted_list_of_set)
  qed
  also have 2: "... = insort a (sorted_list_of_set I) ! Suc i"
    using sorted_list_of_set.insert
    by (metis a_notin_I card.infinite i2 not_less0)
  also have "... = pick I i"
  proof (cases "i = a'")
    case True
    show ?thesis
      by (metis True a_notin_I finI i1_length index_a' insort_nth2 le_refl list.size(3) not_less0
          set_sorted_list_of_set sorted_list_of_set(2) sorted_list_of_set_eq_pick)
  next
    case False
    have "insort a (sorted_list_of_set I) ! Suc i = (sorted_list_of_set I) ! i"
      by (rule insort_nth2, insert i1_length False ia' index_a', auto simp add: a_notin_I finI)
    also have "... = pick I i"
      by (rule sorted_list_of_set_eq_pick[OF i1_length])
    finally show ?thesis .
  qed
  finally show ?thesis .
qed


lemma pick_insert_index:
  assumes Ik: "card I = k"
  and a_notin_I: "a  I"
  and ik: "i < k"
  and a_def: "pick (insert a I) a' = a"
  and a'k: "a' < card I + 1"
shows "pick (insert a I) (insert_index a' i) = pick I i"
proof (cases "i<a'")
  case True
  have "pick (insert a I) i = pick I i"
    by (rule pick_insert[OF a_notin_I _ a_def _ a'k], auto simp add: Ik ik True)
  thus ?thesis using True unfolding insert_index_def by auto
next
  case False note i_ge_a' = False
  have fin_aI: "finite (insert a I)"
    using Ik finite_insert ik by fastforce
  let ?P = "λaa. (aa = a  aa  I)  pick (insert a I) i < aa"
  let ?Q = "λaa. aa  I  pick (insert a I) i < aa"
  have "?P = ?Q" using a_notin_I unfolding fun_eq_iff
    by (auto, metis False Ik a_def card.infinite card_insert_disjoint ik less_SucI
        linorder_neqE_nat not_less_zero order.asym pick_mono_le)
  hence "Least ?P = Least ?Q" by simp
  also have "... = pick I i"
  proof (rule Least_equality, rule conjI)
    show "pick I i  I"
      by (simp add: Ik ik pick_in_set_le)
    show "pick (insert a I) i < pick I i"
      by (rule pick_insert2[OF a_notin_I _ a_def _ a'k], insert False, auto simp add: Ik ik)
    fix y assume y: "y  I  pick (insert a I) i < y"
    let ?xs = "sorted_list_of_set (insert a I)"
    have "y  set ?xs" using y by (metis fin_aI insertI2 set_sorted_list_of_set y)
    from this obtain j where xs_j_y: "?xs ! j = y" and j: "j < length ?xs"
      using in_set_conv_nth by metis
    have ij: "i<j"
      by (metis (no_types, lifting) Ik a_notin_I card.infinite card_insert_disjoint ik j less_SucI
          linorder_neqE_nat not_less_zero order.asym pick_mono_le sorted_list_of_set_eq_pick xs_j_y y)
    have "pick I i = pick (insert a I) (Suc i)"
      by (rule pick_insert3[symmetric, OF a_notin_I _ a_def _ a'k], insert False Ik ik, auto)
    also have "...  pick (insert a I) j"
      by (metis Ik Suc_lessI card.infinite distinct_card distinct_sorted_list_of_set eq_iff
          finite_insert ij ik j less_imp_le_nat not_less_zero pick_mono_le set_sorted_list_of_set)
    also have "... = ?xs ! j" by (rule sorted_list_of_set_eq_pick[symmetric, OF j])
    also have "... = y" by (rule xs_j_y)
    finally show "pick I i  y" .
  qed
  finally show ?thesis unfolding insert_index_def using False by auto
qed


subsection‹Start of the proof›

definition "strict_from_inj n f = (λi. if i{0..<n} then (sorted_list_of_set (f`{0..<n})) ! i else i)"

lemma strict_strict_from_inj:
  fixes f::"nat  nat"
  assumes "inj_on f {0..<n}" shows "strict_mono_on (strict_from_inj n f) {0..<n}"
proof -
  let ?I="f`{0..<n}"
  have "strict_from_inj n f x < strict_from_inj n f y"
    if xy: "x < y" and x: "x  {0..<n}" and y: "y  {0..<n}" for x y
  proof -
    let ?xs = "(sorted_list_of_set ?I)"
    have sorted_xs: "sorted ?xs" by (rule sorted_sorted_list_of_set)
    have "strict_from_inj n f x = (sorted_list_of_set ?I) ! x"
      unfolding strict_from_inj_def using x by auto
    also have "... < (sorted_list_of_set ?I) ! y"
    proof (rule sorted_nth_strict_mono; clarsimp?)
      show "y < card (f ` {0..<n})"
        by (metis assms atLeastLessThan_iff card_atLeastLessThan card_image diff_zero y)
    qed (simp add: xy)
    also have "... = strict_from_inj n f y" using y unfolding strict_from_inj_def by simp
    finally show ?thesis .
  qed
  thus ?thesis unfolding strict_mono_on_def by simp
qed




lemma strict_from_inj_image':
  assumes f: "inj_on f {0..<n}"
  shows "strict_from_inj n f ` {0..<n} = f`{0..<n}"
proof (auto)
  let ?I = "f ` {0..<n}"
  fix xa assume xa: "xa < n"
  have inj_on: "inj_on f {0..<n}" using f  by auto
  have length_I: "length (sorted_list_of_set ?I) = n"
    by (metis card_atLeastLessThan card_image diff_zero distinct_card distinct_sorted_list_of_set
        finite_atLeastLessThan finite_imageI inj_on sorted_list_of_set(1))

  have "strict_from_inj n f xa = sorted_list_of_set ?I ! xa"
    using xa unfolding strict_from_inj_def by auto
  also have "... = pick ?I xa"
    by (rule sorted_list_of_set_eq_pick, unfold length_I, auto simp add: xa)
  also have "...  f ` {0..<n}" by (rule pick_in_set_le, simp add: card_image inj_on xa)
  finally show "strict_from_inj n f xa  f ` {0..<n}" .
  obtain i where "sorted_list_of_set (f`{0..<n}) ! i = f xa" and "i<n"
    by (metis atLeast0LessThan finite_atLeastLessThan finite_imageI imageI
        in_set_conv_nth length_I lessThan_iff sorted_list_of_set(1) xa)
  thus "f xa  strict_from_inj n f ` {0..<n}"
    by (metis atLeast0LessThan imageI lessThan_iff strict_from_inj_def)
qed



definition "Z (n::nat) (m::nat) = {(f,π)|f π. f  {0..<n}  {0..<m}
   (i. i  {0..<n}  f i = i)
   π permutes {0..<n}}"

lemma Z_alt_def: "Z n m = {f. f  {0..<n}  {0..<m}  (i. i  {0..<n}  f i = i)} × {π. π permutes {0..<n}}"
  unfolding Z_def by auto

lemma det_mul_finsum_alt:
  assumes A: "A  carrier_mat n m"
    and B: "B  carrier_mat m n"
  shows "det (A*B) = det (matr n n (λi. finsum_vec TYPE('a::comm_ring_1) n
  (λk. B $$ (k, i) v Matrix.col A k) {0..<m}))"
proof -
  have AT: "AT  carrier_mat m n" using A by auto
  have BT: "BT  carrier_mat n m" using B by auto
  let ?f = "(λi. finsum_vec TYPE('a) n (λk. BT $$ (i, k) v Matrix.row AT k) {0..<m})"
  let ?g = "(λi. finsum_vec TYPE('a) n (λk. B $$ (k, i) v Matrix.col A k) {0..<m})"
  let ?lhs = "matr n n ?f"
  let ?rhs = "matr n n ?g"
  have lhs_rhs: "?lhs = ?rhs"
  proof (rule eq_matI)
    show "dim_row ?lhs = dim_row ?rhs" by auto
    show "dim_col ?lhs = dim_col ?rhs" by auto
    fix i j assume i: "i < dim_row ?rhs" and j: "j < dim_col ?rhs"
    have j_n: "j<n" using j by auto
    have "?lhs $$ (i, j) = ?f i $v j" by (rule index_mat, insert i j, auto)
    also have "... = (k{0..<m}. (BT $$ (i, k) v row AT k) $ j)"
      by (rule index_finsum_vec[OF _ j_n], auto simp add: A)
    also have "... = (k{0..<m}. (B $$ (k, i) v col A k) $ j)"
    proof (rule sum.cong, auto)
      fix x assume x: "x<m"
      have row_rw: "Matrix.row AT x = col A x" by (rule row_transpose, insert A x, auto)
      have B_rw: "BT $$ (i,x) = B $$ (x, i)"
        by (rule index_transpose_mat, insert x i B, auto)
      have "(BT $$ (i, x) v Matrix.row AT x) $v j = BT $$ (i, x) * Matrix.row AT x $v j"
        by (rule index_smult_vec, insert A j_n, auto)
      also have "... = B $$ (x, i) * col A x $v j" unfolding row_rw B_rw by simp
      also have "... = (B $$ (x, i) v col A x) $v j"
        by (rule index_smult_vec[symmetric], insert A j_n, auto)
      finally show " (BT $$ (i, x) v Matrix.row AT x) $v j = (B $$ (x, i) v col A x) $v j" .
    qed
    also have "... = ?g i $v j"
      by (rule index_finsum_vec[symmetric, OF _ j_n], auto simp add: A)
    also have "... = ?rhs $$ (i, j)" by (rule index_mat[symmetric], insert i j, auto)
    finally show "?lhs $$ (i, j) = ?rhs $$ (i, j)" .
  qed
  have "det (A*B) = det (BT*AT)"
    using det_transpose
    by (metis A B Matrix.transpose_mult mult_carrier_mat)
  also have "... =  det (matr n n (λi. finsum_vec TYPE('a) n (λk. BT $$ (i, k) v Matrix.row AT k) {0..<m}))"
    using mat_mul_finsum_alt[OF BT AT] by auto
  also have "... = det (matr n n (λi. finsum_vec TYPE('a) n (λk. B $$ (k, i) v Matrix.col A k) {0..<m}))"
    by (rule arg_cong[of _ _ det], rule lhs_rhs)
  finally show ?thesis .
qed


lemma det_cols_mul:
  assumes A: "A  carrier_mat n m"
    and B: "B  carrier_mat m n"
  shows "det (A*B) = (f | (i{0..<n}. f i  {0..<m})  (i. i  {0..<n}  f i = i).
       (i = 0..<n. B $$ (f i, i)) * Determinant.det (matr n n (λi. col A (f i))))"
proof -
  let ?V="{0..<n}"
  let ?U = "{0..<m}"
  let ?F = " {f. (i {0..<n}. f i  ?U)  (i. i  {0..<n}  f i = i)}"
  let ?g = "λf. det (matr n n (λ i. B $$ (f i, i) v col A (f i)))"
  have fm: "finite {0..<m}" by auto
  have fn: "finite {0..<n}" by auto
  have det_rw: "det (matr n n (λi. B $$ (f i, i) v col A (f i))) =
    (prod (λi. B $$ (f i, i)) {0..<n}) * det (matr n n (λi. col A (f i)))"
    if  f: "(i{0..<n}. f i  {0..<m})  (i. i  {0..<n}  f i = i)" for f
    by (rule det_rows_mul, insert A col_dim, auto)
  have "det (A*B) = det (matr n n (λi. finsum_vec TYPE('a::comm_ring_1) n (λk. B $$ (k, i) v Matrix.col A k) ?U))"
    by (rule det_mul_finsum_alt[OF A B])
  also have "... = sum ?g ?F" by (rule det_linear_rows_sum[OF fm], auto simp add: A)
  also have "... = (f?F. prod (λi. B $$ (f i, i)) {0..<n} * det (matr n n (λi. col A (f i))))"
    using det_rw by auto
  finally show ?thesis .
qed

lemma det_cols_mul':
  assumes A: "A  carrier_mat n m"
    and B: "B  carrier_mat m n"
  shows "det (A*B) = (f | (i{0..<n}. f i  {0..<m})  (i. i  {0..<n}  f i = i).
       (i = 0..<n. A $$ (i, f i)) * det (matr n n (λi. row B (f i))))"
proof -
  let ?F="{f. (i{0..<n}. f i  {0..<m})  (i. i  {0..<n}  f i = i)}"
  have t: "A * B = (BT*AT)T" using transpose_mult[OF A B] transpose_transpose by metis
  have "det (BT*AT) = (f?F. (i = 0..<n. AT $$ (f i, i)) * det (matr n n (λi. col BT (f i))))"
    by (rule det_cols_mul, auto simp add: A B)
  also have "... = (f ?F. (i = 0..<n. A $$ (i, f i)) * det (matr n n (λi. row B (f i))))"
  proof (rule sum.cong, rule refl)
    fix f assume f: "f  ?F"
    have "(i = 0..<n. AT $$ (f i, i)) = (i = 0..<n. A $$ (i, f i))"
    proof (rule prod.cong, rule refl)
      fix x assume x: "x  {0..<n}"
      show "AT $$ (f x, x) = A $$ (x, f x)"
        by (rule index_transpose_mat(1), insert f A x, auto)
    qed
    moreover have "det (matr n n (λi. col BT (f i))) = det (matr n n (λi. row B (f i)))"
    proof -
      have row_eq_colT: "row B (f i) $v j = col BT (f i) $v j" if i: "i < n" and j: "j < n" for i j
      proof -
        have fi_m: "f i < m" using f i by auto
        have "col BT (f i) $v j = BT $$(j, f i)" by (rule index_col, insert B fi_m j, auto)
        also have "... = B $$ (f i, j)" using B fi_m j by auto
        also have "... = row B (f i) $v j" by (rule index_row[symmetric], insert B fi_m j, auto)
        finally show ?thesis ..
      qed
      show ?thesis by (rule arg_cong[of _ _ det], rule eq_matI, insert row_eq_colT, auto)
    qed
    ultimately show "(i = 0..<n. AT $$ (f i, i)) * det (matr n n (λi. col BT (f i))) =
         (i = 0..<n. A $$ (i, f i)) * det (matr n n (λi. row B (f i)))" by simp
  qed
  finally show ?thesis
    by (metis (no_types, lifting) A B det_transpose transpose_mult mult_carrier_mat)
qed

(*We need a more general version of this lemma*)
lemma
  assumes F: "F= {f. f  {0..<n}  {0..<m}  (i. i  {0..<n}  f i = i)}"
  and p: " π permutes {0..<n}"
  shows " (fF. (i = 0..<n. B $$ (f i, π i))) = (fF. (i = 0..<n. B $$ (f i, i)))"
proof -
  let ?h = "(λf. f  π)"
  have inj_on_F: "inj_on ?h F"
  proof (rule inj_onI)
    fix f g assume fop: "f  π = g  π"
    have "f x = g x" for x
    proof (cases "x  {0..<n}")
      case True
      then show ?thesis
        by (metis fop comp_apply p permutes_def)
    next
      case False
      then show ?thesis
        by (metis fop comp_eq_elim p permutes_def)
    qed
    thus "f = g" by auto
  qed
  have hF: "?h` F = F"
    unfolding image_def
  proof auto
    fix xa assume xa: "xa  F" show "xa  π  F"
      unfolding o_def F
      using F PiE p xa
      by (auto, smt F atLeastLessThan_iff mem_Collect_eq p permutes_def xa)
    show "xF. xa = x  π"
    proof (rule bexI[of _ "xa  Hilbert_Choice.inv π"])
      show "xa = xa  Hilbert_Choice.inv π  π"
        using p by auto
      show "xa  Hilbert_Choice.inv π  F"
        unfolding o_def F
        using F PiE p xa
        by (auto, smt atLeastLessThan_iff permutes_def permutes_less(3))
    qed
  qed
  have prod_rw: "(i = 0..<n. B $$ (f i, i)) = (i = 0..<n. B $$ (f (π i), π i))" if "fF" for f
  using prod.permute[OF p] by auto
  let ?g = "λf. (i = 0..<n. B $$ (f i, π i))"
  have "(fF. (i = 0..<n. B $$ (f i, i))) = (fF. (i = 0..<n. B $$ (f (π i), π i)))"
    using prod_rw by auto
  also have "... = (f(?h`F). i = 0..<n. B $$ (f i, π i))"
    using sum.reindex[OF inj_on_F, of ?g] unfolding hF by auto
  also have "... = (fF. i = 0..<n. B $$ (f i, π i))" unfolding hF by auto
  finally show ?thesis ..
qed


lemma detAB_Znm_aux:
  assumes F: "F= {f. f  {0..<n}  {0..<m}  (i. i  {0..<n}  f i = i)}"
  shows"(π | π permutes {0..<n}. (fF. prod (λi. B $$ (f i, i)) {0..<n}
        * (signof π * (i = 0..<n. A $$ (π i, f i)))))
    = (π | π permutes {0..<n}. fF. (i = 0..<n. B $$ (f i, π i))
        * (signof π * (i = 0..<n. A $$ (i, f i))))"
proof -
  have "(π | π permutes {0..<n}. (fF. prod (λi. B $$ (f i, i)) {0..<n}
      * (signof π * (i = 0..<n. A $$ (π i, f i))))) =
    (π | π permutes {0..<n}. fF. signof π * (i = 0..<n. B $$ (f i, i) * A $$ (π i, f i)))"
    by (smt mult.left_commute prod.cong prod.distrib sum.cong)
  also have "... = (π | π permutes {0..<n}. fF. signof (Hilbert_Choice.inv π)
    * (i = 0..<n. B $$ (f i, i) * A $$ (Hilbert_Choice.inv π i, f i)))"
    by (rule sum_permutations_inverse)
  also have "... = (π | π permutes {0..<n}. fF. signof (Hilbert_Choice.inv π)
    * (i = 0..<n. B $$ (f (π i), (π i)) * A $$ (Hilbert_Choice.inv π (π i), f (π i))))"
  proof (rule sum.cong)
    fix x assume x: "x  {π. π permutes {0..<n}}"
    let ?inv_x = "Hilbert_Choice.inv x"
    have p: "x permutes {0..<n}" using x by simp
    have prod_rw: "(i = 0..<n. B $$ (f i, i) * A $$ (?inv_x i, f i))
        = (i = 0..<n. B $$ (f (x i), x i) * A $$ (?inv_x (x i), f (x i)))" if "f  F" for f
      using prod.permute[OF p] by auto
    then show "(fF. signof ?inv_x * (i = 0..<n. B $$ (f i, i) * A $$ (?inv_x i, f i))) =
         (fF. signof ?inv_x * (i = 0..<n. B $$ (f (x i), x i) * A $$ (?inv_x (x i), f (x i))))"
      by auto
  qed (simp)
  also have "... = (π | π permutes {0..<n}. fF. signof π
    * (i = 0..<n. B $$ (f (π i), (π i)) * A $$ (i, f (π i))))"
    by (rule sum.cong, auto, rule sum.cong, auto)
        (metis (no_types, lifting) finite_atLeastLessThan signof_inv)
  also have "... = (π | π permutes {0..<n}. fF. signof π
    * (i = 0..<n. B $$ (f i, (π i)) * A $$ (i, f i)))"
  proof (rule sum.cong)
    fix π assume p: "π  {π. π permutes {0..<n}}"
    hence p: "π permutes {0..<n}" by auto
    let ?inv_pi = "(Hilbert_Choice.inv π)"
    let ?h = "(λf. f  (Hilbert_Choice.inv π))"
  have inj_on_F: "inj_on ?h F"
  proof (rule inj_onI)
    fix f g assume fop: "f  ?inv_pi = g  ?inv_pi"
    have "f x = g x" for x
    proof (cases "x  {0..<n}")
      case True
      then show ?thesis
        by (metis fop o_inv_o_cancel p permutes_inj)
    next
      case False
      then show ?thesis
        by (metis fop o_inv_o_cancel p permutes_inj)
    qed
    thus "f = g" by auto
  qed
  have hF: "?h` F = F"
    unfolding image_def
  proof auto
    fix xa assume xa: "xa  F" show "xa  ?inv_pi  F"
      unfolding o_def F
      using F PiE p xa
      by (auto, smt atLeastLessThan_iff permutes_def permutes_less(3))
    show "xF. xa = x  ?inv_pi"
    proof (rule bexI[of _ "xa  π"])
      show "xa = xa  π  Hilbert_Choice.inv π "
        using p by auto
      show "xa  π  F"
        unfolding o_def F
        using F PiE p xa
        by (auto, smt atLeastLessThan_iff permutes_def permutes_less(3))
    qed
  qed
  let ?g = "λf. signof π * (i = 0..<n. B $$ (f (π i), π i) * A $$ (i, f (π i)))"
    show "(fF. signof π * (i = 0..<n. B $$ (f (π i), π i) * A $$ (i, f (π i)))) =
         (fF. signof π * (i = 0..<n. B $$ (f i, π i) * A $$ (i, f i)))"
      using sum.reindex[OF inj_on_F, of "?g"] p unfolding hF unfolding o_def by auto
  qed (simp)
  also have "... = (π | π permutes {0..<n}. fF. (i = 0..<n. B $$ (f i, π i))
  * (signof π * (i = 0..<n. A $$ (i, f i))))"
    by (smt mult.left_commute prod.cong prod.distrib sum.cong)
  finally show ?thesis .
qed


lemma detAB_Znm:
  assumes A: "A  carrier_mat n m"
    and B: "B  carrier_mat m n"
  shows "det (A*B) = ((f, π)Z n m. signof π * (i = 0..<n. A $$ (i, f i) * B $$ (f i, π i)))"
proof -
  let ?V="{0..<n}"
  let ?U = "{0..<m}"
  let ?PU = "{p. p permutes ?U}"
  let ?F = " {f. (i {0..<n}. f i  ?U)  (i. i  {0..<n}  f i = i)}"
  let ?f = "λf. det (matr n n (λ i. A $$ (i, f i) v row B (f i)))"
  let ?g = "λf. det (matr n n (λ i. B $$ (f i, i) v col A (f i)))"
  have fm: "finite {0..<m}" by auto
  have fn: "finite {0..<n}" by auto
  have F: "?F= {f. f  {0..<n}  {0..<m}  (i. i  {0..<n}  f i = i)}" by auto
  have det_rw: "det (matr n n (λi. B $$ (f i, i) v col A (f i))) =
    (prod (λi. B $$ (f i, i)) {0..<n}) * det (matr n n (λi. col A (f i)))"
    if  f: "(i{0..<n}. f i  {0..<m})  (i. i  {0..<n}  f i = i)" for f
    by (rule det_rows_mul, insert A col_dim, auto)
  have det_rw2: "det (matr n n (λi. col A (f i)))
  = (π | π permutes {0..<n}. signof π * (i = 0..<n. A $$ (π i, f i)))"
    if f: "f  ?F" for f
  proof (unfold Determinant.det_def, auto, rule sum.cong, auto)
    fix x assume x: "x permutes {0..<n}"
    have "(i = 0..<n. col A (f i) $v x i) = (i = 0..<n. A $$ (x i, f i))"
    proof (rule prod.cong)
      fix xa assume xa: "xa  {0..<n}" show "col A (f xa) $v x xa = A $$ (x xa, f  xa)"
        by (metis A atLeastLessThan_iff carrier_matD(1) col_def index_vec permutes_less(1) x xa)
    qed (auto)
    then show "signof x * (i = 0..<n. col A (f i) $v x i)
      = signof x * (i = 0..<n. A $$ (x i, f i))" by auto
  qed
  have fin_n: "finite {0..<n}" and fin_m: "finite {0..<m}" by auto
  have "det (A*B) = det (matr n n (λi. finsum_vec TYPE('a::comm_ring_1) n
    (λk. B $$ (k, i) v Matrix.col A k) {0..<m}))"
    by (rule det_mul_finsum_alt[OF A B])
  also have "... = sum ?g ?F" by (rule det_linear_rows_sum[OF fm], auto simp add: A)
  also have "... = (f?F. prod (λi. B $$ (f i, i)) {0..<n} * det (matr n n (λi. col A (f i))))"
    using det_rw by auto
  also have "... = (f?F. prod (λi. B $$ (f i, i)) {0..<n} *
  (π | π permutes {0..<n}. signof π * (i = 0..<n. A $$ (π i, f (i)))))"
    by (rule sum.cong, auto simp add: det_rw2)
  also have "... =
  (f?F. π | π permutes {0..<n}. prod (λi. B $$ (f i, i)) {0..<n}
    * (signof π * (i = 0..<n. A $$ (π i, f (i)))))"
    by (simp add: mult_hom.hom_sum)
  also have "... = (π | π permutes {0..<n}. f?F.prod (λi. B $$ (f i, i)) {0..<n}
    * (signof π * (i = 0..<n. A $$ (π i, f i))))"
    by (rule VS_Connect.class_semiring.finsum_finsum_swap,
      insert finite_permutations finite_bounded_functions[OF fin_m fin_n], auto)
  thm detAB_Znm_aux
  also have "... = (π | π permutes {0..<n}. f?F. (i = 0..<n. B $$ (f i, π i))
  * (signof π * (i = 0..<n. A $$ (i, f i))))" by (rule detAB_Znm_aux, auto)
  also have "... = (f?F.π | π permutes {0..<n}. (i = 0..<n. B $$ (f i, π i))
  * (signof π * (i = 0..<n. A $$ (i, f i))))"
    by (rule VS_Connect.class_semiring.finsum_finsum_swap,
      insert finite_permutations finite_bounded_functions[OF fin_m fin_n], auto)
  also have "... =  (f?F.π | π permutes {0..<n}. signof π
    * (i = 0..<n. A $$ (i, f i) * B $$ (f i, π i)))"
    unfolding prod.distrib by (rule sum.cong, auto, rule sum.cong, auto)
  also have "... = sum (λ(f,π). (signof π)
    * (prod (λi. A$$(i,f i) * B $$ (f i, π i)) {0..<n})) (Z n m)"
    unfolding Z_alt_def unfolding sum.cartesian_product[symmetric] F by auto
  finally show ?thesis .
qed

(*Several lemmas here can be moved outside the context*)
context
  fixes n m and A B::"'a::comm_ring_1 mat"
  assumes A: "A  carrier_mat n m"
    and B: "B  carrier_mat m n"
begin

private definition "Z_inj = ({f. f  {0..<n}  {0..<m}  (i. i  {0..<n}  f i = i)
   inj_on f {0..<n}} × {π. π permutes {0..<n}})"

private definition "Z_not_inj = ({f. f  {0..<n}  {0..<m}  (i. i  {0..<n}  f i = i)
   ¬ inj_on f {0..<n}} × {π. π permutes {0..<n}})"

private definition "Z_strict = ({f. f  {0..<n}  {0..<m}  (i. i  {0..<n}  f i = i)
   strict_mono_on f {0..<n}} × {π. π permutes {0..<n}})"

private definition "Z_not_strict = ({f. f  {0..<n}  {0..<m}  (i. i  {0..<n}  f i = i)
   ¬ strict_mono_on f {0..<n}} × {π. π permutes {0..<n}})"

private definition "weight f π
  = (signof π) * (prod (λi. A$$(i,f i) * B $$ (f i, π i)) {0..<n})"

private definition "Z_good g = ({f. f  {0..<n}  {0..<m}  (i. i  {0..<n}  f i = i)
   inj_on f {0..<n}  (f`{0..<n} = g`{0..<n})} × {π. π permutes {0..<n}})"

private definition "F_strict = {f. f  {0..<n}  {0..<m}
   (i. i  {0..<n}  f i = i)  strict_mono_on f {0..<n}}"

private definition "F_inj = {f. f  {0..<n}  {0..<m}
   (i. i  {0..<n}  f i = i)  inj_on f {0..<n}}"

private definition "F_not_inj = {f. f  {0..<n}  {0..<m}
   (i. i  {0..<n}  f i = i)  ¬ inj_on f {0..<n}}"

private definition "F = {f. f  {0..<n}  {0..<m}  (i. i  {0..<n}  f i = i)}"

text‹The Cauchy--Binet formula is proven in \url{https://core.ac.uk/download/pdf/82475020.pdf}
  In that work, they define @{text "σ ≡ inv φ ∘ π"}. I had problems following this proof
  in Isabelle, since I was demanded to show that such permutations commute, which is false.
  It is a notation problem of the  @{text "∘"} operator, the author means @{text "σ ≡ π ∘ inv φ"} using
  the Isabelle notation (i.e., @{text "σ x = π ((inv φ) x)"}).
›

lemma step_weight:
  fixes φ π
  defines "σ  π  Hilbert_Choice.inv φ"
  assumes f_inj: "f  F_inj" and gF: "g  F" and pi: "π permutes {0..<n}"
  and phi: "φ permutes {0..<n}" and fg_phi: "x  {0..<n}. f x = g (φ x)"
shows "weight f π = (signof φ) * (i = 0..<n. A $$ (i, g (φ i)))
  * (signof σ) * (i = 0..<n. B $$ (g i, σ i))"
proof -
  let ?A = "(i = 0..<n. A $$ (i, g (φ i))) "
  let ?B = "(i = 0..<n. B $$ (g i, σ i))"
  have sigma: "σ permutes {0..<n}" unfolding σ_def
    by (rule permutes_compose[OF permutes_inv[OF phi] pi])
  have A_rw: "?A = (i = 0..<n. A $$ (i, f i))" using fg_phi by auto
  have "?B = (i = 0..<n. B $$ (g (φ i), σ (φ i)))"
    by (rule prod.permute[unfolded o_def, OF phi])
  also have "... = (i = 0..<n. B $$ (f i, π i))"
    using fg_phi
    unfolding σ_def unfolding o_def unfolding permutes_inverses(2)[OF phi] by auto
  finally have B_rw: "?B = (i = 0..<n. B $$ (f i, π i))" .
  have "(signof φ) * ?A * (signof σ) * ?B = (signof φ) * (signof σ) * ?A * ?B" by auto
  also have "... = signof (φ  σ) * ?A * ?B" unfolding signof_compose[OF phi sigma] by simp
  also have "... = signof π * ?A * ?B"
    by (metis (no_types, lifting) σ_def mult.commute o_inv_o_cancel permutes_inj
        phi sigma signof_compose)
  also have "... = signof π * (i = 0..<n. A $$ (i, f i)) * (i = 0..<n. B $$ (f i, π i))"
    using A_rw B_rw by auto
  also have "... = signof π * (i = 0..<n. A $$ (i, f i) * B $$ (f i, π i))" by auto
  also have "... = weight f π" unfolding weight_def by simp
  finally show ?thesis ..
qed


lemma Z_good_fun_alt_sum:
  fixes g
  defines "Z_good_fun  {f. f  {0..<n}  {0..<m}  (i. i  {0..<n}  f i = i)
     inj_on f {0..<n}  (f`{0..<n} = g`{0..<n})}"
  assumes g: "g  F_inj"
  shows "(fZ_good_fun. P f)= (π{π. π permutes {0..<n}}. P (g  π))"
proof -
  let ?f = "λπ. g  π"
  let ?P = "{π. π permutes {0..<n}}"
  have fP: "?f`?P = Z_good_fun"
  proof (unfold Z_good_fun_def, auto)
    fix xa xb assume "xa permutes {0..<n}" and "xb < n"
    hence "xa xb < n" by auto
    thus "g (xa xb) < m" using g unfolding F_inj_def by fastforce
  next
    fix xa i assume "xa permutes {0..<n}" and i_ge_n: "¬ i < n"
    hence "xa i = i" unfolding permutes_def by auto
    thus "g (xa i) = i" using g i_ge_n unfolding F_inj_def by auto
  next
    fix xa assume "xa permutes {0..<n}" thus "inj_on (g  xa) {0..<n}"
      by (metis (mono_tags, lifting) F_inj_def atLeast0LessThan comp_inj_on g
          mem_Collect_eq permutes_image permutes_inj_on)
  next
    fix π xb assume "π permutes {0..<n}" and "xb < n" thus " g xb  (λx. g (π x)) ` {0..<n}"
      by (metis (full_types) atLeast0LessThan imageI image_image lessThan_iff permutes_image)
  next
   fix x assume x1: "x  {0..<n}  {0..<m}" and x2: "i. ¬ i < n  x i = i"
     and inj_on_x: "inj_on x {0..<n}" and xg: "x ` {0..<n} = g ` {0..<n}"
   let  = "λi. if i<n then (THE j. j<n  x i = g j) else i"
   show "x  (∘) g ` {π. π permutes {0..<n}}"
   proof (unfold image_def, auto, rule exI[of _ ], rule conjI)
     have " i = i" if i: "i  {0..<n}" for i
       using i by auto
     moreover have "∃!j.  j = i" for i
     proof (cases "i<n")
       case True
       obtain a where xa_gi: "x a = g i" and a: "a < n" using xg True
         by (metis (mono_tags, hide_lams) atLeast0LessThan imageE imageI lessThan_iff)
       show ?thesis
       proof (rule ex1I[of _ a])
         have the_ai: "(THE j. j < n  x a = g j) = i"
         proof (rule theI2)
           show "i < n  x a = g i" using xa_gi True by auto
           fix xa assume "xa < n  x a = g xa" thus "xa = i"
             by (metis (mono_tags, lifting) F_inj_def True atLeast0LessThan
                g inj_onD lessThan_iff mem_Collect_eq xa_gi)
           thus "xa = i" .
         qed
         thus ta: " a = i" using a by auto
         fix j assume tj: " j = i"
         show "j = a"
         proof (cases "j<n")
           case True
           obtain b where xj_gb: "x j = g b" and b: "b < n" using xg True
             by (metis (mono_tags, hide_lams) atLeast0LessThan imageE imageI lessThan_iff)
           let ?P = "λja. ja < n  x j = g ja"
           have the_ji: "(THE ja. ja < n  x j = g ja) = i" using tj True by auto
           have "?P (THE ja. ?P ja)"
           proof (rule theI)
            show "b < n  x j = g b" using xj_gb b by auto
            fix xa assume "xa < n  x j = g xa" thus "xa = b"
              by (metis (mono_tags, lifting) F_inj_def b atLeast0LessThan
                  g inj_onD lessThan_iff mem_Collect_eq xj_gb)
           qed
           hence "x j = g i" unfolding the_ji by auto
           hence "x j = x a" using xa_gi by auto
           then show ?thesis using inj_on_x a True unfolding inj_on_def by auto
         next
           case False
           then show ?thesis using tj True by auto
         qed
       qed
     next
       case False note i_ge_n = False
       show ?thesis
       proof (rule ex1I[of _ i])
         show " i = i" using False by simp
         fix j assume tj: " j = i"
         show "j = i"
         proof (cases "j<n")
           case True
           obtain a where xj_ga: "x j = g a" and a: "a < n" using xg True
             by (metis (mono_tags, hide_lams) atLeast0LessThan imageE imageI lessThan_iff)
           have "(THE ja. ja < n  x j = g ja) < n"
           proof (rule theI2)
             show "a < n  x j = g a" using xj_ga a by auto
             fix xa assume a1: "xa < n  x j = g xa" thus "xa = a"
               using F_inj_def  a atLeast0LessThan g inj_on_eq_iff xj_ga by fastforce
             show "xa < n" by (simp add: a1)
           qed
            then show ?thesis using tj i_ge_n by auto
          next
            case False
            then show ?thesis using tj  by auto
          qed
       qed
     qed
     ultimately show " permutes {0..<n}" unfolding permutes_def by auto
     show "x = g  "
     proof -
       have "x xa = g (THE j. j < n  x xa = g j)" if xa: "xa < n" for xa
       proof -
         obtain c where c: "c < n" and xxa_gc: "x xa = g c"
           by (metis (mono_tags, hide_lams) atLeast0LessThan imageE imageI lessThan_iff xa xg)
         show ?thesis
         proof (rule theI2)
           show c1: "c < n  x xa = g c" using c xxa_gc by auto
           fix xb assume c2: "xb < n  x xa = g xb" thus "xb = c"
             by (metis (mono_tags, lifting) F_inj_def c1 atLeast0LessThan
                 g inj_onD lessThan_iff mem_Collect_eq)
           show "x xa = g xb" using c1 c2 by simp
         qed
       qed
       moreover have "x xa = g xa" if xa: "¬ xa < n" for xa
         using g x1 x2 xa unfolding F_inj_def by simp
       ultimately show ?thesis unfolding o_def fun_eq_iff by auto
     qed
   qed
 qed
  have inj: "inj_on ?f ?P"
  proof (rule inj_onI)
    fix x y assume x: "x  ?P" and y: "y  ?P" and gx_gy: "g  x = g  y"
    have "x i = y i" for i
    proof (cases "i<n")
      case True
      hence xi: "x i  {0..<n}" and yi: "y i  {0..<n}" using x y by auto
      have "g (x i) = g (y i)" using gx_gy unfolding o_def by meson
      thus ?thesis using xi yi using g unfolding F_inj_def inj_on_def by blast
    next
      case False
      then show ?thesis using x y unfolding permutes_def by auto
    qed
    thus "x = y" unfolding fun_eq_iff by auto
  qed
  have "(fZ_good_fun. P f) = (f?f`?P. P f)" using fP by simp
  also have "... =  sum (P  (∘) g) {π. π permutes {0..<n}}"
    by (rule sum.reindex[OF inj])
  also have "... =  (π | π permutes {0..<n}. P (g  π))" by auto
  finally show ?thesis .
qed


lemma F_injI:
  assumes "f  {0..<n}  {0..<m}"
  and "(i. i  {0..<n}  f i = i)" and "inj_on f {0..<n}"
  shows "f  F_inj" using assms unfolding F_inj_def by simp

lemma F_inj_composition_permutation:
  assumes phi: "φ permutes {0..<n}"
  and g: "g  F_inj"
  shows "g  φ  F_inj"
proof (rule F_injI)
  show "g  φ  {0..<n}  {0..<m}"
    using g unfolding permutes_def F_inj_def
    by (simp add: Pi_iff phi)
  show "i. i  {0..<n}  (g  φ) i = i"
    using g phi unfolding permutes_def F_inj_def by simp
  show "inj_on (g  φ) {0..<n}"
    by (rule comp_inj_on, insert g permutes_inj_on[OF phi] permutes_image[OF phi])
       (auto simp add: F_inj_def)
qed


lemma F_strict_imp_F_inj:
  assumes f: "f  F_strict"
  shows "f  F_inj"
  using f strict_mono_on_imp_inj_on
  unfolding F_strict_def F_inj_def by auto


lemma one_step:
  assumes g1: "g  F_strict"
  shows "det (submatrix A UNIV (g`{0..<n})) * det (submatrix B (g`{0..<n}) UNIV)
    = ((x, y)  Z_good g. weight x y)" (is "?lhs = ?rhs")
proof -
  define Z_good_fun where "Z_good_fun = {f. f  {0..<n}  {0..<m}  (i. i  {0..<n}  f i = i)
     inj_on f {0..<n}  (f`{0..<n} = g`{0..<n})}"
  let ?Perm = "{π. π permutes {0..<n}}"
  let ?P = "(λf. π  ?Perm. weight f π)"
  let ?inv = "Hilbert_Choice.inv"
  have g: "g  F_inj" by (rule F_strict_imp_F_inj[OF g1])
  have detA: "(φ{π. π permutes {0..<n}}. signof φ * (i = 0..<n. A $$ (i, g (φ i))))
    = det (submatrix A UNIV (g`{0..<n}))"
  proof -
    have "{j. j < dim_col A  j  g ` {0..<n}} = {j. j  g ` {0..<n}}"
      using g A unfolding F_inj_def by fastforce
    also have "card ... = n" using F_inj_def card_image g by force
    finally have card_J: "card {j. j < dim_col A  j  g ` {0..<n}} = n" by simp
    have subA_carrier: "submatrix A UNIV (g ` {0..<n})  carrier_mat n n"
      unfolding submatrix_def card_J using A by auto
    have "det (submatrix A UNIV (g`{0..<n})) = (p | p permutes {0..<n}.
            signof p * (i = 0..<n. submatrix A UNIV (g ` {0..<n}) $$ (i, p i)))"
      using subA_carrier unfolding Determinant.det_def by auto
    also have "... = (φ{π. π permutes {0..<n}}. signof φ * (i = 0..<n. A $$ (i, g (φ i))))"
    proof (rule sum.cong)
      fix x assume x: "x  {π. π permutes {0..<n}}"
      have "(i = 0..<n. submatrix A UNIV (g ` {0..<n}) $$ (i, x i))
          = (i = 0..<n. A $$ (i, g (x i)))"
      proof (rule prod.cong, rule refl)
        fix i assume i: "i  {0..<n}"
        have pick_rw: "pick (g ` {0..<n}) (x i) = g (x i)"
        proof -
          have "index (sorted_list_of_set (g ` {0..<n})) (g (x i)) = x i"
          proof -
            have rw: "sorted_list_of_set (g ` {0..<n}) = map g [0..<n]"
              by (rule sorted_list_of_set_map_strict, insert g1, simp add: F_strict_def)
            have "index (sorted_list_of_set (g`{0..<n})) (g (x i)) = index (map g [0..<n]) (g (x i))"
              unfolding rw by auto
            also have "... = index [0..<n] (x i)"
              by (rule index_map_inj_on[of _ "{0..<n}"], insert x i g, auto simp add: F_inj_def)
            also have "... = x i" using x i by auto
            finally show ?thesis .
          qed
          moreover have "(g (x i))   (g ` {0..<n})" using x g i unfolding F_inj_def by auto
          moreover have "x i < card (g ` {0..<n})" using x i g by (simp add: F_inj_def card_image)
          ultimately show ?thesis using pick_index by auto
        qed
        have "submatrix A UNIV (g`{0..<n}) $$ (i, x i) = A $$ (pick UNIV i, pick (g`{0..<n}) (x i))"
          by (rule submatrix_index, insert i A card_J x, auto)
        also have "... = A $$ (i, g (x i))" using pick_rw pick_UNIV by auto
        finally show "submatrix A UNIV (g ` {0..<n}) $$ (i, x i) = A $$ (i, g (x i))" .
      qed
      thus "signof x * (i = 0..<n. submatrix A UNIV (g ` {0..<n}) $$ (i, x i))
        = signof x * (i = 0..<n. A $$ (i, g (x i)))" by auto
    qed (simp)
    finally show ?thesis by simp
  qed
  have detB_rw: "(π  ?Perm. signof (π  ?inv φ) * (i = 0..<n. B $$ (g i, (π  ?inv φ) i)))
   = (π  ?Perm. signof (π) * (i = 0..<n. B $$ (g i, π i)))"
    if phi: "φ permutes {0..<n}" for φ
  proof -
    let ?h="λπ. π  ?inv φ"
    let ?g = "λπ. signof (π) * (i = 0..<n. B $$ (g i, π i))"
    have "?h`?Perm = ?Perm"
    proof -
      have "π  ?inv φ permutes {0..<n}" if pi: "π permutes {0..<n}" for π
        using permutes_compose permutes_inv phi that by blast
      moreover have "x  (λπ. π  ?inv φ) ` ?Perm" if "x permutes {0..<n}" for x
      proof -
        have "x  φ permutes {0..<n}"
          using permutes_compose phi that by blast
        moreover have "x = x  φ  ?inv φ" using phi by auto
        ultimately show ?thesis unfolding image_def by auto
      qed
      ultimately show ?thesis by auto
    qed
    hence "(π  ?Perm. ?g π) = (π  ?h`?Perm. ?g π)" by simp
    also have "... = sum (?g  ?h) ?Perm"
    proof (rule sum.reindex)
      show "inj_on (λπ. π  ?inv φ) {π. π permutes {0..<n}}"
        by (metis (no_types, lifting) inj_onI o_inv_o_cancel permutes_inj phi)
    qed
    also have "... = (π  ?Perm. signof (π  ?inv φ) * (i = 0..<n. B $$ (g i, (π  ?inv φ) i)))"
      unfolding o_def by auto
    finally show ?thesis by simp
  qed

  have detB: "det (submatrix B (g`{0..<n}) UNIV)
    = (π  ?Perm. signof π * (i = 0..<n. B $$ (g i, π i)))"
  proof -
    have "{i. i < dim_row B  i  g ` {0..<n}} = {i. i  g ` {0..<n}}"
     using g B unfolding F_inj_def by fastforce
    also have "card ... = n" using F_inj_def card_image g by force
    finally have card_I: "card {j. j < dim_row B  j  g ` {0..<n}} = n" by simp
    have subB_carrier: "submatrix B (g ` {0..<n}) UNIV  carrier_mat n n"
      unfolding submatrix_def using card_I B by auto
    have "det (submatrix B (g`{0..<n}) UNIV) = (p  ?Perm. signof p
      * (i=0..<n. submatrix B (g ` {0..<n}) UNIV $$ (i, p i)))"
      unfolding Determinant.det_def using subB_carrier by auto
    also have "... = (π  ?Perm. signof π * (i = 0..<n. B $$ (g i, π i)))"
    proof (rule sum.cong, rule refl)
      fix x assume x: "x  {π. π permutes {0..<n}}"
      have "(i=0..<n. submatrix B (g`{0..<n}) UNIV $$ (i, x i)) = (i=0..<n. B $$ (g i, x i))"
      proof (rule prod.cong, rule refl)
        fix i assume i: "i  {0..<n}"
        have pick_rw: "pick (g ` {0..<n}) i = g i"
        proof -
          have "index (sorted_list_of_set (g ` {0..<n})) (g i) = i"
          proof -
            have rw: "sorted_list_of_set (g ` {0..<n}) = map g [0..<n]"
              by (rule sorted_list_of_set_map_strict, insert g1, simp add: F_strict_def)
            have "index (sorted_list_of_set (g`{0..<n})) (g i) = index (map g [0..<n]) (g i)"
              unfolding rw by auto
            also have "... = index [0..<n] (i)"
              by (rule index_map_inj_on[of _ "{0..<n}"], insert x i g, auto simp add: F_inj_def)
            also have "... = i" using i by auto
            finally show ?thesis .
          qed
          moreover have "(g i)   (g ` {0..<n})" using x g i unfolding F_inj_def by auto
          moreover have "i < card (g ` {0..<n})" using x i g by (simp add: F_inj_def card_image)
          ultimately show ?thesis using pick_index by auto
        qed
        have "submatrix B (g`{0..<n}) UNIV $$ (i, x i) = B $$ (pick (g`{0..<n}) i, pick UNIV (x i))"
          by (rule submatrix_index, insert i B card_I x, auto)
        also have "... = B $$ (g i, x i)" using pick_rw pick_UNIV by auto
        finally show "submatrix B (g ` {0..<n}) UNIV $$ (i, x i) = B $$ (g i, x i)" .
      qed
      thus "signof x * (i = 0..<n. submatrix B (g ` {0..<n}) UNIV $$ (i, x i))
          = signof x * (i = 0..<n. B $$ (g i, x i))" by simp
    qed
    finally show ?thesis .
  qed

  have "?rhs = (fZ_good_fun. π?Perm. weight f π)"
    unfolding Z_good_def sum.cartesian_product Z_good_fun_def by blast
  also have "... = (φ{π. π permutes {0..<n}}. ?P (g  φ))" unfolding Z_good_fun_def
    by (rule Z_good_fun_alt_sum[OF g])
  also have "... = (φ{π. π permutes {0..<n}}. π{π. π permutes {0..<n}}.
    signof φ * (i = 0..<n. A $$ (i, g (φ i))) * signof (π  ?inv φ)
    * (i = 0..<n. B $$ (g i, (π  ?inv φ) i)))"
  proof (rule sum.cong, simp, rule sum.cong, simp)
    fix φ π assume phi: "φ  ?Perm" and pi: "π  ?Perm"
    show "weight (g  φ) π = signof φ * (i = 0..<n. A $$ (i, g (φ i))) *
      signof (π  ?inv φ) * (i = 0..<n. B $$ (g i, (π  ?inv φ) i))"
    proof (rule step_weight)
      show "g  φ  F_inj" by (rule F_inj_composition_permutation[OF _ g], insert phi, auto)
      show "g  F" using g unfolding F_def F_inj_def by simp
    qed (insert phi pi, auto)
  qed
  also have "... = (φ{π. π permutes {0..<n}}. signof φ * (i = 0..<n. A $$ (i, g (φ i))) *
     (π | π permutes {0..<n}. signof (π  ?inv φ) * (i = 0..<n. B $$ (g i, (π  ?inv φ) i))))"
    by (metis (mono_tags, lifting) Groups.mult_ac(1) semiring_0_class.sum_distrib_left sum.cong)
  also have "... = (φ  ?Perm. signof φ * (i = 0..<n. A $$ (i, g (φ i))) *
    (π  ?Perm. signof π * (i = 0..<n. B $$ (g i, π i))))" using detB_rw by auto
  also have "... = (φ  ?Perm. signof φ * (i = 0..<n. A $$ (i, g (φ i)))) *
    (π  ?Perm. signof π * (i = 0..<n. B $$ (g i, π i)))"
    by (simp add: semiring_0_class.sum_distrib_right)
  also have "... = ?lhs" unfolding detA detB ..
  finally show ?thesis ..
qed


lemma gather_by_strictness:
"sum (λg. sum (λ(f,π). weight f π) (Z_good g)) F_strict
  = sum (λg. det (submatrix A UNIV (g`{0..<n})) * det (submatrix B (g`{0..<n}) UNIV)) F_strict"
proof (rule sum.cong)
  fix f assume f: "f  F_strict"
  show "((x, y)Z_good f. weight x y)
    = det (submatrix A UNIV (f ` {0..<n})) * det (submatrix B (f ` {0..<n}) UNIV)"
    by (rule one_step[symmetric], rule f)
qed (simp)

lemma finite_Z_strict[simp]: "finite Z_strict"
proof (unfold Z_strict_def, rule finite_cartesian_product)
  have finN: "finite {0..<n}" and finM: "finite {0..<m}" by auto
  let ?A="{f  {0..<n}  {0..<m}. (i. i  {0..<n}  f i = i)  strict_mono_on f {0..<n}}"
  let ?B="{f  {0..<n}  {0..<m}. (i. i  {0..<n}  f i = i)}"
  have B: "{f. (i{0..<n}. f i  {0..<m})  (i. i  {0..<n}  f i = i)} = ?B" by auto
  have "?A?B" by auto
  moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto
  ultimately show "finite ?A" using rev_finite_subset by blast
  show "finite {π. π permutes {0..<n}}" using finite_permutations by blast
qed

lemma finite_Z_not_strict[simp]: "finite Z_not_strict"
proof (unfold Z_not_strict_def, rule finite_cartesian_product)
  have finN: "finite {0..<n}" and finM: "finite {0..<m}" by auto
  let ?A="{f  {0..<n}  {0..<m}. (i. i  {0..<n}  f i = i)  ¬ strict_mono_on f {0..<n}}"
  let ?B="{f  {0..<n}  {0..<m}. (i. i  {0..<n}  f i = i)}"
  have B: "{f. (i{0..<n}. f i  {0..<m})  (i. i  {0..<n}  f i = i)} = ?B" by auto
  have "?A?B" by auto
  moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto
  ultimately show "finite ?A" using rev_finite_subset by blast
  show "finite {π. π permutes {0..<n}}" using finite_permutations by blast
qed

lemma finite_Znm[simp]: "finite (Z n m)"
proof (unfold Z_alt_def, rule finite_cartesian_product)
  have finN: "finite {0..<n}" and finM: "finite {0..<m}" by auto
  let ?A="{f  {0..<n}  {0..<m}. (i. i  {0..<n}  f i = i) }"
  let ?B="{f  {0..<n}  {0..<m}. (i. i  {0..<n}  f i = i)}"
  have B: "{f. (i{0..<n}. f i  {0..<m})  (i. i  {0..<n}  f i = i)} = ?B" by auto
  have "?A?B" by auto
  moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto
  ultimately show "finite ?A" using rev_finite_subset by blast
  show "finite {π. π permutes {0..<n}}" using finite_permutations by blast
qed

lemma finite_F_inj[simp]: "finite F_inj"
proof -
  have finN: "finite {0..<n}" and finM: "finite {0..<m}" by auto
  let ?A="{f  {0..<n}  {0..<m}. (i. i  {0..<n}  f i = i)  inj_on f {0..<n}}"
  let ?B="{f  {0..<n}  {0..<m}. (i. i  {0..<n}  f i = i)}"
  have B: "{f. (i{0..<n}. f i  {0..<m})  (i. i  {0..<n}  f i = i)} = ?B" by auto
  have "?A?B" by auto
  moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto
  ultimately show "finite F_inj" unfolding F_inj_def using rev_finite_subset by blast
qed

lemma finite_F_strict[simp]: "finite F_strict"
proof -
 have finN: "finite {0..<n}" and finM: "finite {0..<m}" by auto
  let ?A="{f  {0..<n}  {0..<m}. (i. i  {0..<n}  f i = i)  strict_mono_on f {0..<n}}"
  let ?B="{f  {0..<n}  {0..<m}. (i. i  {0..<n}  f i = i)}"
  have B: "{f. (i{0..<n}. f i  {0..<m})  (i. i  {0..<n}  f i = i)} = ?B" by auto
  have "?A?B" by auto
  moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto
  ultimately show "finite F_strict" unfolding F_strict_def using rev_finite_subset by blast
qed

lemma nth_strict_mono:
  fixes f::"nat  nat"
  assumes  strictf: "strict_mono f" and i: "i<n"
shows "f i = (sorted_list_of_set (f`{0..<n})) ! i"
proof -
  let ?I = "f`{0..<n}"
  have "length (sorted_list_of_set (f ` {0..<n})) = card ?I"
    by (metis distinct_card finite_atLeastLessThan finite_imageI
        sorted_list_of_set(1) sorted_list_of_set(3))
  also have "... = n"
    by (simp add: card_image strict_mono_imp_inj_on strictf)
  finally have length_I: "length (sorted_list_of_set ?I) = n" .
  have card_eq: "card {a  ?I. a < f i} = i"
    using i
  proof (induct i)
    case 0
    then show ?case
      by (auto simp add: strict_mono_less strictf)
  next
    case (Suc i)
    have i: "i < n" using Suc.prems by auto
    let ?J'="{a  f ` {0..<n}. a < f i}"
    let ?J = "{a  f ` {0..<n}. a < f (Suc i)}"
    have cardJ': "card ?J' = i" by (rule Suc.hyps[OF i])
    have J: "?J = insert (f i) ?J'"
    proof (auto)
      fix xa assume 1: "f xa  f i" and 2: "f xa < f (Suc i)"
      show "f xa < f i"
        using 1 2 not_less_less_Suc_eq strict_mono_less strictf by fastforce
    next
      fix xa assume "f xa < f i" thus "f xa < f (Suc i)"
        using less_SucI strict_mono_less strictf by blast
    next
      show "f i  f ` {0..<n}" using i by auto
      show "f i < f (Suc i)" using strictf strict_mono_less by auto
    qed
    have "card ?J = Suc (card ?J')" by (unfold J, rule card_insert_disjoint, auto)
    then show ?case using cardJ' by auto
  qed
  have "sorted_list_of_set ?I ! i = pick ?I i"
    by (rule sorted_list_of_set_eq_pick, simp add: ‹card (f ` {0..<n}) = n i)
  also have "... =  pick ?I (card {a  ?I. a < f i})" unfolding card_eq by simp
  also have "... = f i" by (rule pick_card_in_set, simp add: i)
  finally show ?thesis ..
qed

lemma nth_strict_mono_on:
  fixes f::"nat  nat"
  assumes  strictf: "strict_mono_on f {0..<n}" and i: "i<n"
shows "f i = (sorted_list_of_set (f`{0..<n})) ! i"
proof -
  let ?I = "f`{0..<n}"
  have "length (sorted_list_of_set (f ` {0..<n})) = card ?I"
    by (metis distinct_card finite_atLeastLessThan finite_imageI
        sorted_list_of_set(1) sorted_list_of_set(3))
  also have "... = n"
    by (metis (mono_tags, lifting) card_atLeastLessThan card_image diff_zero
        inj_on_def strict_mono_on_eqD strictf)
  finally have length_I: "length (sorted_list_of_set ?I) = n" .
  have card_eq: "card {a  ?I. a < f i} = i"
    using i
  proof (induct i)
    case 0
    then show ?case
      by (auto, metis (no_types, lifting) atLeast0LessThan lessThan_iff less_Suc_eq
          not_less0 not_less_eq strict_mono_on_def strictf)
  next
    case (Suc i)
    have i: "i < n" using Suc.prems by auto
    let ?J'="{a  f ` {0..<n}. a < f i}"
    let ?J = "{a  f ` {0..<n}. a < f (Suc i)}"
    have cardJ': "card ?J' = i" by (rule Suc.hyps[OF i])
    have J: "?J = insert (f i) ?J'"
    proof (auto)
      fix xa assume 1: "f xa  f i" and 2: "f xa < f (Suc i)" and 3: "xa < n"
      show "f xa < f i"
        by (metis (full_types) 1 2 3 antisym_conv3 atLeast0LessThan i lessThan_iff
            less_SucE order.asym strict_mono_onD strictf)
    next
      fix xa assume "f xa < f i" and "xa < n" thus "f xa < f (Suc i)"
        using less_SucI strictf
        by (metis (no_types, lifting) Suc.prems atLeast0LessThan
            lessI lessThan_iff less_trans strict_mono_onD)
    next
      show "f i  f ` {0..<n}" using i by auto
      show "f i < f (Suc i)"
        using Suc.prems strict_mono_onD strictf by fastforce
    qed
    have "card ?J = Suc (card ?J')" by (unfold J, rule card_insert_disjoint, auto)
    then show ?case using cardJ' by auto
  qed
  have "sorted_list_of_set ?I ! i = pick ?I i"
    by (rule sorted_list_of_set_eq_pick, simp add: ‹card (f ` {0..<n}) = n i)
  also have "... =  pick ?I (card {a  ?I. a < f i})" unfolding card_eq by simp
  also have "... = f i" by (rule pick_card_in_set, simp add: i)
  finally show ?thesis ..
qed

lemma strict_fun_eq:
  assumes f: "f  F_strict" and g: "g  F_strict" and fg: "f`{0..<n} = g`{0..<n}"
  shows "f = g"
proof (unfold fun_eq_iff, auto)
  fix x
  show "f x = g x"
  proof (cases "x<n")
    case True
    have strictf: "strict_mono_on f {0..<n}" and strictg: "strict_mono_on g {0..<n}"
      using f g unfolding F_strict_def by auto
    have "f x = (sorted_list_of_set (f`{0..<n})) ! x" by (rule nth_strict_mono_on[OF strictf True])
    also have "... = (sorted_list_of_set (g`{0..<n})) ! x" unfolding fg by simp
    also have "... = g x" by (rule nth_strict_mono_on[symmetric, OF strictg True])
    finally show ?thesis .
  next
    case False
    then show ?thesis using f g unfolding F_strict_def by auto
  qed
qed


lemma strict_from_inj_preserves_F:
  assumes f: "f  F_inj"
  shows "strict_from_inj n f  F"
proof -
  {
    fix x assume x: "x < n"
    have inj_on: "inj_on f {0..<n}" using f unfolding F_inj_def by auto
    have "{a. a < m  a  f ` {0..<n}} = f`{0..<n}" using f unfolding F_inj_def by auto
    hence card_eq: "card {a. a < m  a  f ` {0..<n}} = n"
      by (simp add: card_image inj_on)
    let ?I = "f`{0..<n}"
    have "length (sorted_list_of_set (f ` {0..<n})) = card ?I"
      by (metis distinct_card finite_atLeastLessThan finite_imageI
          sorted_list_of_set(1) sorted_list_of_set(3))
    also have "... = n"
      by (simp add: card_image strict_mono_imp_inj_on inj_on)
    finally have length_I: "length (sorted_list_of_set ?I) = n" .
    have "sorted_list_of_set (f ` {0..<n}) ! x = pick (f ` {0..<n}) x"
      by (rule sorted_list_of_set_eq_pick, unfold length_I, auto simp add: x)
    also have "... < m" by (rule pick_le, unfold card_eq, rule x)
    finally have "sorted_list_of_set (f ` {0..<n}) ! x < m" .
  }
  thus ?thesis unfolding strict_from_inj_def F_def by auto
qed

lemma strict_from_inj_F_strict: "strict_from_inj n xa  F_strict"
  if xa: "xa  F_inj" for xa
proof -
  have "strict_mono_on (strict_from_inj n xa) {0..<n}"
    by (rule strict_strict_from_inj, insert xa, simp add: F_inj_def)
  thus ?thesis using strict_from_inj_preserves_F[OF xa] unfolding F_def F_strict_def by auto
qed

lemma strict_from_inj_image:
  assumes f: "f F_inj"
  shows "strict_from_inj n f ` {0..<n} = f`{0..<n}"
proof (auto)
  let ?I = "f ` {0..<n}"
  fix xa assume xa: "xa < n"
  have inj_on: "inj_on f {0..<n}" using f unfolding F_inj_def by auto
    have "{a. a < m  a  f ` {0..<n}} = f`{0..<n}" using f unfolding F_inj_def by auto
    hence card_eq: "card {a. a < m  a  f ` {0..<n}} = n"
      by (simp add: card_image inj_on)
    let ?I = "f`{0..<n}"
    have "length (sorted_list_of_set (f ` {0..<n})) = card ?I"
      by (metis distinct_card finite_atLeastLessThan finite_imageI
          sorted_list_of_set(1) sorted_list_of_set(3))
    also have "... = n"
      by (simp add: card_image strict_mono_imp_inj_on inj_on)
    finally have length_I: "length (sorted_list_of_set ?I) = n" .
  have "strict_from_inj n f xa = sorted_list_of_set ?I ! xa"
    using xa unfolding strict_from_inj_def by auto
  also have "... = pick ?I xa"
    by (rule sorted_list_of_set_eq_pick, unfold length_I, auto simp add: xa)
  also have "...  f ` {0..<n}" by (rule pick_in_set_le, simp add: ‹card (f ` {0..<n}) = n xa)
  finally show "strict_from_inj n f xa  f ` {0..<n}" .
  obtain i where "sorted_list_of_set (f`{0..<n}) ! i = f xa" and "i<n"
    by (metis atLeast0LessThan finite_atLeastLessThan finite_imageI imageI
        in_set_conv_nth length_I lessThan_iff sorted_list_of_set(1) xa)
  thus "f xa  strict_from_inj n f ` {0..<n}"
    by (metis atLeast0LessThan imageI lessThan_iff strict_from_inj_def)
qed


lemma Z_good_alt:
  assumes g: "g  F_strict"
  shows "Z_good g = {x  F_inj. strict_from_inj n x = g} × {π. π permutes {0..<n}}"
proof -
  define Z_good_fun where "Z_good_fun = {f. f  {0..<n}  {0..<m}  (i. i  {0..<n}  f i = i)
   inj_on f {0..<n}  (f`{0..<n} = g`{0..<n})}"
  have "Z_good_fun = {x  F_inj. strict_from_inj n x = g}"
  proof (auto)
    fix f assume f: "f  Z_good_fun" thus f_inj: "f  F_inj" unfolding F_inj_def Z_good_fun_def by auto
    show "strict_from_inj n f = g"
    proof (rule strict_fun_eq[OF _ g])
      show "strict_from_inj n f ` {0..<n} = g ` {0..<n}"
        using f_inj f strict_from_inj_image
        unfolding Z_good_fun_def F_inj_def by auto
      show "strict_from_inj n f  F_strict"
        using F_strict_def f_inj strict_from_inj_F_strict by blast
    qed
  next
    fix f assume f_inj: "f  F_inj" and g_strict_f: "g = strict_from_inj n f"
    have "f xa  g ` {0..<n}" if "xa < n" for xa
      using f_inj g_strict_f strict_from_inj_image that by auto
    moreover have "g xa  f ` {0..<n}" if "xa < n" for xa
      by (metis f_inj g_strict_f imageI lessThan_atLeast0 lessThan_iff strict_from_inj_image that)
    ultimately show "f  Z_good_fun"
      using f_inj g_strict_f unfolding Z_good_fun_def F_inj_def
      by auto
  qed
  thus ?thesis unfolding Z_good_fun_def Z_good_def by simp
qed


lemma weight_0: "((f, π)  Z_not_inj. weight f π) = 0"
proof -
  let ?F="{f. (i{0..<n}. f i  {0..<m})  (i. i  {0..<n}  f i = i)}"
  let ?Perm = "{π. π permutes {0..<n}}"
  have "((f, π)Z_not_inj. weight f π)
    = (f  F_not_inj. (i = 0..<n. A $$ (i, f i)) * det (matr n n (λi. row B (f i))))"
  proof -
    have dim_row_rw: "dim_row (matr n n (λi. col A (f i))) = n" for f by auto
    have dim_row_rw2: "dim_row (matr n n (λi. Matrix.row B (f i))) = n" for f by auto
    have prod_rw: "(i = 0..<n. B $$ (f i, π i)) =  (i = 0..<n. row B (f i) $v π i)"
      if f: "f  F_not_inj" and pi: "π  ?Perm" for f π
    proof (rule prod.cong, rule refl)
      fix x assume x: "x  {0..<n}"
      have "f x < dim_row B" using f B x unfolding F_not_inj_def by fastforce
      moreover have "π x < dim_col B" using x pi B by auto
      ultimately show "B $$ (f x, π x) = Matrix.row B (f x) $v π x" by (rule index_row[symmetric])
    qed
    have sum_rw: "(π | π permutes {0..<n}. signof π * (i = 0..<n. B $$ (f i, π i)))
      = det (matr n n (λi. row B (f i)))" if f: "f  F_not_inj" for f
      unfolding Determinant.det_def using dim_row_rw2 prod_rw f by auto
    have "((f, π)Z_not_inj. weight f π) = (fF_not_inj.π  ?Perm. weight f π)"
      unfolding Z_not_inj_def unfolding sum.cartesian_product
      unfolding F_not_inj_def by simp
    also have "... = (fF_not_inj. π | π permutes {0..<n}. signof π
      * (i = 0..<n. A $$ (i, f i) * B $$ (f i, π i)))"
      unfolding weight_def by simp
    also have "... = (fF_not_inj. (i = 0..<n. A $$ (i, f i))
      * (π | π permutes {0..<n}. signof π * (i = 0..<n. B $$ (f i, π i))))"
      by (rule sum.cong, rule refl, auto)
         (metis (no_types, lifting) mult.left_commute mult_hom.hom_sum sum.cong)
    also have "... = (f  F_not_inj. (i = 0..<n. A $$ (i, f i))
      * det (matr n n (λi. row B (f i))))" using sum_rw by auto
    finally show ?thesis by auto
  qed
  also have "... = 0"
    by (rule sum.neutral, insert det_not_inj_on[of _ n B], auto simp add: F_not_inj_def)
  finally show ?thesis .
qed

subsection ‹Final theorem›

lemma Cauchy_Binet1:
  shows "det (A*B) =
  sum (λf. det (submatrix A UNIV (f`{0..<n})) * det (submatrix B (f`{0..<n}) UNIV)) F_strict"
(is "?lhs = ?rhs")
proof -
  have sum0: "((f, π)  Z_not_inj. weight f π) = 0" by (rule weight_0)
  let ?f = "strict_from_inj n"
  have sum_rw: "sum g F_inj = (y  F_strict. sum g {x  F_inj. ?f x = y})" for g
    by (rule sum.group[symmetric], insert strict_from_inj_F_strict, auto)
  have Z_Union: "Z_inj  Z_not_inj = Z n m"
    unfolding Z_def Z_not_inj_def Z_inj_def by auto
  have Z_Inter: "Z_inj  Z_not_inj = {}"
    unfolding Z_def Z_not_inj_def Z_inj_def by auto
  have "det (A*B) = ((f, π)Z n m. weight f π)"
    using detAB_Znm[OF A B] unfolding weight_def by auto
  also have "... = ((f, π)Z_inj. weight f π) + ((f, π)Z_not_inj. weight f π)"
    by (metis Z_Inter Z_Union finite_Un finite_Znm sum.union_disjoint)
  also have "... = ((f, π)Z_inj. weight f π)" using sum0 by force
  also have "... = (f  F_inj. π{π. π permutes {0..<n}}. weight f π)"
    unfolding Z_inj_def unfolding F_inj_def sum.cartesian_product ..
  also have "... =  (yF_strict. f{x  F_inj. strict_from_inj n x = y}.
    sum (weight f) {π. π permutes {0..<n}})" unfolding sum_rw ..
  also have "... =  (yF_strict. (f,π)({x  F_inj. strict_from_inj n x = y}
  × {π. π permutes {0..<n}}). weight f π)"
    unfolding F_inj_def sum.cartesian_product ..
  also have "... = sum (λg. sum (λ(f,π). weight f π) (Z_good g)) F_strict"
    using Z_good_alt by auto
  also have "... = ?rhs" unfolding gather_by_strictness by simp
  finally show ?thesis .
qed


lemma Cauchy_Binet:
  "det (A*B) = (I{I. I{0..<m}  card I=n}. det (submatrix A UNIV I) * det (submatrix B I UNIV))"
proof -
  let ?f="(λI. (λi. if i<n then sorted_list_of_set I ! i else i))"
  let ?setI = "{I. I  {0..<m}  card I = n}"
  have inj_on: "inj_on ?f ?setI"
  proof (rule inj_onI)
    fix I J assume I: "I  ?setI" and J: "J  ?setI" and fI_fJ: "?f I = ?f J"
    have "x  J" if x: "x  I" for x
      by (metis (mono_tags) fI_fJ I J distinct_card in_set_conv_nth mem_Collect_eq
          sorted_list_of_set(1) sorted_list_of_set(3) subset_eq_atLeast0_lessThan_finite x)
    moreover have "x  I" if x: "x  J" for x
      by (metis (mono_tags) fI_fJ I J distinct_card in_set_conv_nth mem_Collect_eq
          sorted_list_of_set(1) sorted_list_of_set(3) subset_eq_atLeast0_lessThan_finite x)
    ultimately show "I = J" by auto
  qed
  have rw: "?f I ` {0..<n} = I" if I: "I  ?setI" for I
  proof -
    have "sorted_list_of_set I ! xa  I" if "xa < n" for xa
      by (metis (mono_tags, lifting) I distinct_card distinct_sorted_list_of_set mem_Collect_eq
          nth_mem set_sorted_list_of_set subset_eq_atLeast0_lessThan_finite that)
    moreover have "xa{0..<n}. x = sorted_list_of_set I ! xa" if x: "xI" for x
      by (metis (full_types) x I atLeast0LessThan distinct_card in_set_conv_nth mem_Collect_eq
         lessThan_iff sorted_list_of_set(1) sorted_list_of_set(3) subset_eq_atLeast0_lessThan_finite)
    ultimately show ?thesis unfolding image_def by auto
  qed
  have f_setI: "?f` ?setI = F_strict"
  proof -
    have "sorted_list_of_set I ! xa < m" if I: "I  {0..<m}" and "n = card I" and "xa < card I"
        for I xa
      by (metis I xa < card I atLeast0LessThan distinct_card finite_atLeastLessThan lessThan_iff
          pick_in_set_le rev_finite_subset sorted_list_of_set(1)
          sorted_list_of_set(3) sorted_list_of_set_eq_pick subsetCE)
    moreover have "strict_mono_on (λi. if i < card I then sorted_list_of_set I ! i else i) {0..<card I}"
      if "I  {0..<m}" and "n = card I" for I
      by (smt I  {0..<m} atLeastLessThan_iff distinct_card finite_atLeastLessThan pick_mono_le
          rev_finite_subset sorted_list_of_set(1) sorted_list_of_set(3)
          sorted_list_of_set_eq_pick strict_mono_on_def)
    moreover have "x  ?f ` {I. I  {0..<m}  card I = n}"
      if x1: "x  {0..<n}  {0..<m}" and x2: "i. ¬ i < n  x i = i"
      and s: "strict_mono_on x {0..<n}" for x
    proof -
      have inj_x: "inj_on x {0..<n}"
        using s strict_mono_on_imp_inj_on by blast
      hence card_xn: "card (x ` {0..<n}) = n" by (simp add: card_image)
      have x_eq: "x = (λi. if i < n then sorted_list_of_set (x ` {0..<n}) ! i else i)"
        unfolding fun_eq_iff
        using nth_strict_mono_on s using x2 by auto
      show ?thesis
        unfolding image_def by (auto, rule exI[of _"x`{0..<n}"], insert card_xn x1 x_eq, auto)
    qed
    ultimately show ?thesis unfolding F_strict_def by auto
  qed
  let ?g = "(λf. det (submatrix A UNIV (f`{0..<n})) * det(submatrix B (f`{0..<n}) UNIV))"
  have "det (A*B) = sum ((λf. det (submatrix A UNIV (f ` {0..<n}))
    * det (submatrix B (f ` {0..<n}) UNIV))  ?f) {I. I  {0..<m}  card I = n}"
    unfolding Cauchy_Binet1 f_setI[symmetric] by (rule sum.reindex[OF inj_on])
  also have "... = (I{I. I{0..<m}  card I=n}.det(submatrix A UNIV I)*det(submatrix B I UNIV))"
    by (rule sum.cong, insert rw, auto)
  finally show ?thesis .
qed
end

end

Theory Smith_Normal_Form_JNF

(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section ‹Definition of Smith normal form in JNF›

theory Smith_Normal_Form_JNF
  imports
    SNF_Missing_Lemmas
begin

text ‹Now, we define diagonal matrices and Smith normal form in JNF›

definition "isDiagonal_mat A = (i j. i  j  i < dim_row A  j < dim_col A  A$$(i,j) = 0)"

definition "Smith_normal_form_mat A = 
  (
    (a. a + 1 < min (dim_row A) (dim_col A)  A $$ (a,a) dvd A $$ (a+1,a+1))
     isDiagonal_mat A    
  )"

lemma SNF_first_divides:
  assumes SNF_A: "Smith_normal_form_mat A" and "(A::('a::comm_ring_1) mat)  carrier_mat n m"
  and i: "i < min (dim_row A) (dim_col A)"
shows "A $$ (0,0) dvd A $$ (i,i)"
  using i
proof (induct i)
  case 0
  then show ?case by auto
next
  case (Suc i)
  show ?case 
    by (metis (full_types) Smith_normal_form_mat_def Suc.hyps Suc.prems 
        Suc_eq_plus1 Suc_lessD SNF_A dvd_trans)
qed

lemma Smith_normal_form_mat_intro:
  assumes "(a. a + 1 < min (dim_row A) (dim_col A)  A $$ (a,a) dvd A $$ (a+1,a+1))"
    and "isDiagonal_mat A" 
  shows "Smith_normal_form_mat A"
  unfolding Smith_normal_form_mat_def using assms by auto

lemma Smith_normal_form_mat_m0[simp]:
  assumes A: "Acarrier_mat m 0"
  shows "Smith_normal_form_mat A"
  using A unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto

lemma Smith_normal_form_mat_0m[simp]:
  assumes A: "Acarrier_mat 0 m"
  shows "Smith_normal_form_mat A"
  using A unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto

lemma S00_dvd_all_A:
  assumes A: "(A::'a::comm_ring_1 mat)  carrier_mat m n"
  and P: "P  carrier_mat m m"
  and Q: "Q  carrier_mat n n"
  and inv_P: "invertible_mat P"
  and inv_Q: "invertible_mat Q"
  and S_PAQ: "S = P*A*Q"
  and SNF_S: "Smith_normal_form_mat S"
  and i: "i<m" and j: "j<n"
shows "S$$(0,0) dvd A $$ (i,j)"
proof -
  have S00: "(i j. i<m  j<n  S$$(0,0) dvd S$$(i,j))"
    using SNF_S unfolding Smith_normal_form_mat_def isDiagonal_mat_def
    by (smt P Q SNF_first_divides A S_PAQ SNF_S carrier_matD 
        dvd_0_right min_less_iff_conj mult_carrier_mat)
    obtain P' where PP': "inverts_mat P P'" and P'P: "inverts_mat P' P"
      using inv_P unfolding invertible_mat_def by auto
    obtain Q' where QQ': "inverts_mat Q Q'" and Q'Q: "inverts_mat Q' Q"
      using inv_Q unfolding invertible_mat_def by auto
    have A_P'SQ': "P'*S*Q' = A"
    proof -
      have "P'*S*Q' = P'*(P*A*Q)*Q'" unfolding S_PAQ by auto
      also have "... = (P'*P)*A*(Q*Q')"
        by (smt A PP' Q Q'Q P assoc_mult_mat carrier_mat_triv index_mult_mat(2) index_mult_mat(3) 
            index_one_mat(3) inverts_mat_def right_mult_one_mat)
      also have "... = A"
        by (metis A P'P QQ' A Q P carrier_matD(1) index_mult_mat(3) index_one_mat(3) inverts_mat_def
            left_mult_one_mat right_mult_one_mat)
      finally show ?thesis .
    qed
    have "(i j. i<m  j<n  S$$(0,0) dvd (P'*S*Q')$$(i,j))"
    proof (rule dvd_elements_mult_matrix_left_right[OF _ _ _ S00])
      show "S  carrier_mat m n" using P A Q S_PAQ by auto
      show "P'  carrier_mat m m"
        by (metis (mono_tags, lifting) A_P'SQ' PP' P A carrier_matD carrier_matI index_mult_mat(2) 
            index_mult_mat(3) inverts_mat_def one_carrier_mat)
      show "Q'  carrier_mat n n"
        by (metis (mono_tags, lifting) A_P'SQ' Q'Q Q A carrier_matD(2) carrier_matI 
            index_mult_mat(3) inverts_mat_def one_carrier_mat)
    qed
    thus ?thesis using A_P'SQ' i j by auto
qed


lemma SNF_first_divides_all:
  assumes SNF_A: "Smith_normal_form_mat A" and A: "(A::('a::comm_ring_1) mat)  carrier_mat m n"
  and i: "i < m" and j: "j<n"
shows "A $$ (0,0) dvd A $$ (i,j)"
proof (cases "i=j")
  case True
  then show ?thesis using assms SNF_first_divides by (metis carrier_matD min_less_iff_conj)
next
  case False
  hence "A$$(i,j) = 0" using SNF_A i j A unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto
  then show ?thesis by auto
qed

(*This can also be obtained from HOL Analysis via local type definitions*)
lemma SNF_divides_diagonal:
  fixes A::"'a::comm_ring_1 mat"
  assumes A: "A  carrier_mat n m" 
    and SNF_A: "Smith_normal_form_mat A"
    and j: "j < min n m"
    and ij: "ij"
  shows "A$$(i,i) dvd A$$(j,j)" 
  using ij j
proof (induct j)
  case 0
  then show ?case by auto
next
  case (Suc j)
  show ?case
  proof (cases "ij")
    case True
    have "A $$ (i, i) dvd A $$ (j, j)" using Suc.hyps Suc.prems True by simp
    also have "... dvd A $$ (Suc j, Suc j)" 
      using SNF_A Suc.prems A 
      unfolding Smith_normal_form_mat_def by auto
    finally show ?thesis by auto 
  next
    case False
    hence "i=Suc j" using Suc.prems by auto
    then show ?thesis by auto
  qed
qed

lemma Smith_zero_imp_zero:
  fixes A::"'a::comm_ring_1 mat"
  assumes  A: "A  carrier_mat m n"
    and SNF: "Smith_normal_form_mat A"
    and Aii: "A$$(i,i) = 0" 
    and j: "j<min m n" 
    and ij: "ij"
  shows "A$$(j,j) = 0"
proof -
  have "A$$(i,i) dvd A$$(j,j)" by (rule SNF_divides_diagonal[OF A SNF j ij])
  thus ?thesis using Aii by auto
qed

lemma SNF_preserved_multiples_identity:
  assumes S: "S  carrier_mat m n" and SNF: "Smith_normal_form_mat (S::'a::comm_ring_1 mat)"
  shows "Smith_normal_form_mat (S*(k m 1m n))"
proof (rule Smith_normal_form_mat_intro)
  have rw: "S*(k m 1m n) = Matrix.mat m n (λ(i, j). S $$ (i, j) * k)"
    unfolding mat_diag_smult[symmetric] by (rule mat_diag_mult_right[OF S])
  show "isDiagonal_mat (S * (k m 1m n))" 
    using SNF S unfolding Smith_normal_form_mat_def isDiagonal_mat_def rw
    by auto
  show "a. a + 1 < min (dim_row (S * (k m 1m n))) (dim_col (S * (k m 1m n))) 
        (S * (k m 1m n)) $$ (a, a) dvd (S * (k m 1m n)) $$ (a + 1, a + 1)"
    using SNF S unfolding Smith_normal_form_mat_def isDiagonal_mat_def rw
    by (auto simp add: mult_dvd_mono)
qed

end

Theory Rings2_Extended

(*
    Author:      Jose Divasón
    Email:       jose.divason@unirioja.es
*)

section ‹Some theorems about rings and ideals›

theory Rings2_Extended
  imports
    Echelon_Form.Rings2
    "HOL-Types_To_Sets.Types_To_Sets"
begin

subsection ‹Missing properties on ideals›

lemma ideal_generated_subset2:
  assumes  "bB. b  ideal_generated A"
  shows "ideal_generated B  ideal_generated A"
  by (metis (mono_tags, lifting) InterE assms ideal_generated_def
ideal_ideal_generated mem_Collect_eq subsetI)

context comm_ring_1
begin

lemma ideal_explicit: "ideal_generated S
      = {y. f U. finite U  U  S  (iU. f i * i) = y}"
  by (simp add: ideal_generated_eq_left_ideal left_ideal_explicit)
end

lemma ideal_generated_minus:
  assumes a: "a  ideal_generated (S-{a})"
  shows "ideal_generated S = ideal_generated (S-{a})"
proof (cases "a  S")
  case True note a_in_S = True
  show ?thesis
  proof
    show "ideal_generated S  ideal_generated (S - {a})"
    proof (rule ideal_generated_subset2, auto)
      fix b assume b: "b  S" show "b  ideal_generated (S - {a})"
      proof (cases "b = a")
        case True
        then show ?thesis using a by auto
      next
        case False
        then show ?thesis using b
          by (simp add: ideal_generated_in)
      qed
    qed
    show "ideal_generated (S - {a})  ideal_generated S"
      by (rule ideal_generated_subset, auto)
  qed
next
  case False
  then show ?thesis by simp
qed

lemma ideal_generated_dvd_eq:
  assumes a_dvd_b: "a dvd b"
  and a: "a  S"
  and a_not_b: "a  b"
  shows "ideal_generated S = ideal_generated (S - {b})"
proof
  show "ideal_generated S  ideal_generated (S - {b})"
  proof (rule ideal_generated_subset2, auto)
    fix x assume x: "x  S"
    show "x  ideal_generated (S - {b})"
    proof (cases "x = b")
      case True
      obtain k where b_ak: "b = a * k" using a_dvd_b unfolding dvd_def by blast
      let ?f = "λc. k"
      have "(i{a}. i * ?f i) = x" using True b_ak by auto
      moreover have "{a}  S - {b}" using a_not_b a by auto
      moreover have "finite {a}" by auto
      ultimately show ?thesis
        unfolding ideal_def
        by (metis True b_ak ideal_def ideal_generated_in ideal_ideal_generated insert_subset right_ideal_def)
    next
      case False
      then show ?thesis by (simp add: ideal_generated_in x)
    qed
  qed
  show "ideal_generated (S - {b})  ideal_generated S" by (rule ideal_generated_subset, auto)
qed

lemma ideal_generated_dvd_eq_diff_set:
  assumes i_in_I: "iI" and i_in_J: "i  J" and i_dvd_j: "jJ. i dvd j"
  and f: "finite J"
  shows "ideal_generated I = ideal_generated (I - J)"
  using f i_in_J i_dvd_j i_in_I
  proof (induct J arbitrary: I)
  case empty
    then show ?case by auto
  next
    case (insert x J)
    have "ideal_generated I = ideal_generated (I-{x})"
      by (rule ideal_generated_dvd_eq[of i], insert insert.prems , auto)
    also have "... = ideal_generated ((I-{x}) - J)"
      by (rule insert.hyps, insert insert.prems insert.hyps, auto)
    also have "... = ideal_generated (I - insert x J)"
      using Diff_insert2[of I x J] by auto
    finally show ?case .
  qed


context comm_ring_1
begin

lemma ideal_generated_singleton_subset:
  assumes d: "d  ideal_generated S" and fin_S: "finite S"
  shows "ideal_generated {d}  ideal_generated S"
proof
  fix x assume x: "x  ideal_generated {d}"
  obtain k where x_kd: "x = k*d " using x using obtain_sum_ideal_generated[OF x]
    by (metis finite.emptyI finite.insertI sum_singleton)
  show "x  ideal_generated S"
    using d ideal_eq_right_ideal ideal_ideal_generated right_ideal_def mult_commute x_kd by auto
qed

lemma ideal_generated_singleton_dvd:
  assumes i: "ideal_generated S = ideal_generated {d}" and x: "x  S"
  shows "d dvd x"
  by (metis i x finite.intros dvd_ideal_generated_singleton
      ideal_generated_in ideal_generated_singleton_subset)

lemma ideal_generated_UNIV_insert:
  assumes "ideal_generated S = UNIV"
  shows "ideal_generated (insert a S) = UNIV" using assms
  using local.ideal_generated_subset by blast

lemma ideal_generated_UNIV_union:
  assumes "ideal_generated S = UNIV"
  shows "ideal_generated (A  S) = UNIV"
  using assms local.ideal_generated_subset
  by (metis UNIV_I Un_subset_iff equalityI subsetI)

lemma ideal_explicit2:
  assumes "finite S"
  shows "ideal_generated S = {y. f. (iS. f i * i) = y}"
  by (smt Collect_cong assms ideal_explicit obtain_sum_ideal_generated mem_Collect_eq subsetI)

lemma ideal_generated_unit:
  assumes u: "u dvd 1"
  shows "ideal_generated {u} = UNIV"
proof -
  have "x  ideal_generated {u}" for x
  proof -
    obtain inv_u where inv_u: "inv_u * u = 1" using u unfolding dvd_def
      using local.mult_ac(2) by blast
    have "x = x * inv_u * u" using inv_u by (simp add: local.mult_ac(1))
    also have "...  {k * u |k. k  UNIV}" by auto
    also have "... = ideal_generated {u}" unfolding ideal_generated_singleton by simp
    finally show ?thesis .
  qed
  thus ?thesis by auto
qed


lemma ideal_generated_dvd_subset:
  assumes x: "x  S. d dvd x" and S: "finite S"
  shows "ideal_generated S  ideal_generated {d}"
proof
  fix x assume "x ideal_generated S"
  from this obtain f where f: "(iS. f i * i) = x" using ideal_explicit2[OF S] by auto
  have "d dvd (iS. f i * i)" by (rule dvd_sum, insert x, auto)
  thus "x  ideal_generated {d}"
    using f dvd_ideal_generated_singleton' ideal_generated_in singletonI by blast
qed


lemma ideal_generated_mult_unit:
  assumes f: "finite S" and u: "u dvd 1"
  shows "ideal_generated ((λx. u*x)` S) = ideal_generated S"
  using f
proof (induct S)
  case empty
  then show ?case by auto
next
  case (insert x S)
  obtain inv_u where inv_u: "inv_u * u = 1" using u unfolding dvd_def
    using mult_ac by blast
  have f: "finite (insert (u*x) ((λx. u*x)` S))" using insert.hyps by auto
  have f2: "finite (insert x S)" by (simp add: insert(1))
  have f3: "finite S" by (simp add: insert)
  have f4: "finite ((*) u ` S)" by (simp add: insert)
  have inj_ux: "inj_on (λx. u*x) S" unfolding inj_on_def
    by (auto, metis inv_u local.mult_1_left local.semiring_normalization_rules(18))
  have "ideal_generated ((λx. u*x)` (insert x S)) = ideal_generated (insert (u*x) ((λx. u*x)` S))"
    by auto
  also have "... = {y. f. (iinsert (u*x) ((λx. u*x)` S). f i * i) = y}"
    using ideal_explicit2[OF f] by auto
  also have "... = {y. f. (i(insert x S). f i * i) = y}" (is "?L = ?R")
  proof -
    have "a  ?L"  if a: "a  ?R" for a
    proof -
      obtain f where sum_rw: "(i(insert x S). f i * i) = a" using a by auto
      define b where "b=(iS. f i * i)"
      have "b  ideal_generated S" unfolding b_def ideal_explicit2[OF f3] by auto
      hence "b  ideal_generated ((*) u ` S)" using insert.hyps(3) by auto
      from this obtain g where "(i((*) u ` S). g i * i) = b"
        unfolding ideal_explicit2[OF f4] by auto
      hence sum_rw2: "(iS. f i * i) = (i((*) u ` S). g i * i)" unfolding b_def by auto
      let ?g = "λi. if i = u*x then f x * inv_u else g i"
       have sum_rw3: "sum ((λi. g i * i)  (λx. u*x)) S = sum ((λi. ?g i * i)  (λx. u*x)) S"
        by (rule sum.cong, auto, metis inv_u local.insert(2) local.mult_1_right
              local.mult_ac(2) local.semiring_normalization_rules(18))
      have sum_rw4: "(i(λx. u*x)` S. g i * i) = sum ((λi. g i * i)  (λx. u*x)) S"
        by (rule sum.reindex[OF inj_ux])
      have "a = f x * x + (iS. f i * i)"
        using sum_rw local.insert(1) local.insert(2) by auto
      also have "... = f x * x + (i(λx. u*x)` S. g i * i)" using sum_rw2 by auto
      also have "... = ?g (u * x) * (u * x) + (i(λx. u*x)` S. g i * i)"
        using inv_u by (smt local.mult_1_right local.mult_ac(1))
      also have "... =  ?g (u * x) * (u * x) + sum ((λi. g i * i)  (λx. u*x)) S"
        using sum_rw4 by auto
      also have "... = ((λi. ?g i * i)  (λx. u*x)) x + sum ((λi. g i * i)  (λx. u*x)) S" by auto
      also have "... = ((λi. ?g i * i)  (λx. u*x)) x + sum ((λi. ?g i * i)  (λx. u*x)) S"
        using sum_rw3 by auto
      also have "... = sum ((λi. ?g i * i)  (λx. u*x)) (insert x S)"
        by (rule sum.insert[symmetric], auto simp add: insert)
      also have "... = (iinsert (u * x) ((λx. u*x)` S). ?g i * i)"
        by (smt abel_semigroup.commute f2 image_insert inv_u mult.abel_semigroup_axioms mult_1_right
            semiring_normalization_rules(18) sum.reindex_nontrivial)
      also have "... = (i(λx. u*x)` (insert x S). ?g i * i)" by auto
      finally show ?thesis by auto
    qed
    moreover have "a  ?R" if a: "a  ?L" for a
    proof -
      obtain f where sum_rw: "(i(insert (u * x) ((*) u ` S)). f i * i) = a" using a by auto
      have ux_notin: "u*x  ((*) u ` S)"
        by (metis UNIV_I inj_on_image_mem_iff inj_on_inverseI inv_u local.insert(2) local.mult_1_left
            local.semiring_normalization_rules(18) subsetI)
      let ?f = "(λx. f x * x)"
      have "sum ?f ((*) u ` S)  ideal_generated ((*) u ` S)"
        unfolding ideal_explicit2[OF f4] by auto
      from this obtain g where sum_rw1: "sum (λi. g i * i) S = sum ?f (((*) u ` S))"
        using insert.hyps(3) unfolding ideal_explicit2[OF f3] by blast
      let ?g = "(λi. if i = x  then (f (u*x) *u) * x else g i * i)"
      let ?g' = "λi. if i = x  then f (u*x) * u else g i"
      have sum_rw2: "sum (λi. g i * i) S = sum ?g S" by (rule sum.cong, insert inj_ux ux_notin, auto)
      have "a = (i(insert (u * x) ((*) u ` S)). f i * i)" using sum_rw by simp
      also have "... = ?f (u*x) +  sum ?f (((*) u ` S))"
        by (rule sum.insert[OF f4], insert inj_ux) (metis UNIV_I inj_on_image_mem_iff inj_on_inverseI
            inv_u local.insert(2) local.mult_1_left local.semiring_normalization_rules(18) subsetI)
      also have "... = ?f (u*x) + sum (λi. g i * i) S" unfolding sum_rw1 by auto
      also have "... = ?g x + sum ?g S" unfolding sum_rw2 using mult.assoc by auto
      also have "... = sum ?g (insert x S)" by (rule sum.insert[symmetric, OF f3 insert.hyps(2)])
      also have "... = sum (λi. ?g' i * i) (insert x S)" by (rule sum.cong, auto)
      finally show ?thesis by fast
    qed
    ultimately show ?thesis by blast
  qed
  also have "... = ideal_generated (insert x S)" using ideal_explicit2[OF f2] by auto
  finally show ?case by auto
qed

corollary ideal_generated_mult_unit2:
  assumes u: "u dvd 1"
  shows "ideal_generated {u*a,u*b} = ideal_generated {a,b}"
proof -
  let ?S = "{a,b}"
  have "ideal_generated {u*a,u*b} = ideal_generated ((λx. u*x)` {a,b})" by auto
  also have "... = ideal_generated {a,b}" by (rule ideal_generated_mult_unit[OF _ u], simp)
  finally show ?thesis .
qed

lemma ideal_generated_1[simp]: "ideal_generated {1} = UNIV"
  by (metis ideal_generated_unit dvd_ideal_generated_singleton order_refl)

lemma ideal_generated_pair: "ideal_generated {a,b} = {p*a+q*b | p q. True}"
proof -
  have i: "ideal_generated {a,b} = {y. f. (i{a,b}. f i * i) = y}" using ideal_explicit2 by auto
  show ?thesis
  proof (cases "a=b")
    case True
    show ?thesis using True i
      by (auto, metis mult_ac(2) semiring_normalization_rules)
      (metis (no_types, hide_lams) add_minus_cancel mult_ac ring_distribs semiring_normalization_rules)
  next
    case False
    have 1: "p q. (i{a, b}. f i * i) = p * a + q * b" for f
      by (rule exI[of _ "f a"], rule exI[of _ "f b"], rule sum_two_elements[OF False])
    moreover have "f. (i{a, b}. f i * i) = p * a + q * b" for p q
      by (rule exI[of _ "λi. if i=a then p else q"],
          unfold sum_two_elements[OF False], insert False, auto)
    ultimately show ?thesis using i by auto
  qed
qed

lemma ideal_generated_pair_exists_pq1:
  assumes i: "ideal_generated {a,b} = (UNIV::'a set)"
  shows "p q. p*a + q*b = 1"
  using i unfolding ideal_generated_pair
  by (smt iso_tuple_UNIV_I mem_Collect_eq)

lemma ideal_generated_pair_UNIV:
  assumes sa_tb_u: "s*a+t*b = u" and u: "u dvd 1"
  shows "ideal_generated {a,b} = UNIV"
proof -
  have f: "finite {a,b}" by simp
  obtain inv_u where inv_u: "inv_u * u = 1" using u unfolding dvd_def
    by (metis mult.commute)
  have "x  ideal_generated {a,b}" for x
  proof (cases "a = b")
    case True
    then show ?thesis
      by (metis UNIV_I dvd_def dvd_ideal_generated_singleton' ideal_generated_unit insert_absorb2
          mult.commute sa_tb_u semiring_normalization_rules(34) subsetI subset_antisym u)
  next
    case False note a_not_b = False
    let ?f = "λy. if y = a then inv_u * x * s else inv_u * x * t"
    have "(i{a,b}. ?f i * i) = ?f a * a + ?f b * b" by (rule sum_two_elements[OF a_not_b])
    also have "... = x" using a_not_b sa_tb_u inv_u
      by (auto, metis mult_ac(1) mult_ac(2) ring_distribs(1) semiring_normalization_rules(12))
    finally show ?thesis unfolding ideal_explicit2[OF f] by auto
  qed
  thus ?thesis by auto
qed


lemma ideal_generated_pair_exists:
  assumes l: "(ideal_generated {a,b} = ideal_generated {d})"
  shows "( p q. p*a+q*b = d)"
proof -
  have d: "d  ideal_generated {d}" by (simp add: ideal_generated_in)
  hence "d  ideal_generated {a,b}" using l by auto
  from this obtain p q where "d = p*a+q*b" using ideal_generated_pair[of a b] by auto
  thus ?thesis by auto
qed


lemma obtain_ideal_generated_pair:
  assumes "c  ideal_generated {a,b}"
  obtains p q where "p*a+q*b=c"
proof -
  have "c  {p * a + q * b |p q. True}" using assms ideal_generated_pair by auto
  thus ?thesis using that by auto
qed

lemma ideal_generated_pair_exists_UNIV:
  shows "(ideal_generated {a,b} = ideal_generated {1}) = (p q. p*a+q*b = 1)" (is "?lhs = ?rhs")
proof
  assume r: ?rhs
  have "x  ideal_generated {a,b}" for x
  proof (cases "a=b")
    case True
    then show ?thesis
      by (metis UNIV_I r dvd_ideal_generated_singleton finite.intros ideal_generated_1
          ideal_generated_pair_UNIV ideal_generated_singleton_subset)
  next
    case False
    have f: "finite {a,b}" by simp
    have 1: "1  ideal_generated {a,b}"
      using ideal_generated_pair_UNIV local.one_dvd r by blast
    hence i: "ideal_generated {a,b} = {y. f. (i{a,b}. f i * i) = y}"
      using ideal_explicit2[of "{a,b}"] by auto
    from this obtain f where f: "f a * a + f b * b = 1" using sum_two_elements 1 False by auto
    let ?f = "λy. if y = a then x * f a else x * f b"
    have "(i{a,b}. ?f i * i) = x" unfolding sum_two_elements[OF False] using f False
      using mult_ac(1) ring_distribs(1) semiring_normalization_rules(12) by force
    thus ?thesis unfolding i by auto
  qed
  thus ?lhs by auto
next
  assume ?lhs thus ?rhs using ideal_generated_pair_exists[of a b 1] by auto
qed

corollary ideal_generated_UNIV_obtain_pair:
  assumes "ideal_generated {a,b} = ideal_generated {1}"
  shows " (p q. p*a+q*b = d)"
proof -
  obtain x y where "x*a+y*b = 1" using ideal_generated_pair_exists_UNIV assms by auto
  hence "d*x*a+d*y*b=d"
    using local.mult_ac(1) local.ring_distribs(1) local.semiring_normalization_rules(12) by force
  thus ?thesis by auto
qed



lemma sum_three_elements:
  shows "x y z::'a. (i{a,b,c}. f i * i) = x * a + y * b + z * c"
proof (cases "a  b  b  c  a  c")
  case True
  then show ?thesis by (auto, metis add.assoc)
next
  case False
  have 1: "x y z. f c * c = x * c + y * c + z * c"
    by (rule exI[of _ 0],rule exI[of _ 0], rule exI[of _ "f c"], auto)
  have 2: "x y z. f b * b + f c * c = x * b + y * b + z * c"
    by (rule exI[of _ 0],rule exI[of _ "f b"], rule exI[of _ "f c"], auto)
  have 3: "x y z. f a * a + f c * c = x * a + y * c + z * c"
    by (rule exI[of _ "f a"],rule exI[of _ 0], rule exI[of _ "f c"], auto)
  have 4: "x y z. (i{c, b, c}. f i * i) = x * c + y * b + z * c" if a: "a = c" and b: "b  c"
    by (rule exI[of _ 0],rule exI[of _ "f b"], rule exI[of _ "f c"], insert a b,
        auto simp add: insert_commute)
  show ?thesis using False
    by (cases "b=c", cases "a=c", auto simp add: 1 2 3 4)
qed

lemma sum_three_elements':
  shows "f::'a'a. (i{a,b,c}. f i * i) = x * a + y * b + z * c"
proof (cases "a  b  b  c  a  c")
  case True
  let ?f = "λi. if i = a then x else if i = b then y else if i = c then z else 0"
  show ?thesis by (rule exI[of _ "?f"], insert True mult.assoc, auto simp add: local.add_ac)
next
  case False
  have 1: "f. f c * c = x * c + y * c + z * c"
    by (rule exI[of _ "λi. if i = c then x+y+z else 0"], auto simp add: local.ring_distribs)
  have 2: "f. f a * a + f c * c = x * a + y * c + z * c" if bc: " b = c" and ac: "a  c"
    by (rule exI[of _ "λi. if i = a then x else y+z"], insert ac bc add_ac ring_distribs, auto)
  have 3: "f. f b * b + f c * c = x * b + y * b + z * c" if bc: " b  c" and ac: "a = b"
    by (rule exI[of _ "λi. if i = a then x+y else z"], insert ac bc add_ac ring_distribs, auto)
  have 4: "f. (i{c, b, c}. f i * i) = x * c + y * b + z * c" if a: "a = c" and b: "b  c"
    by (rule exI[of _ "λi. if i = c then x+z else y"], insert a b add_ac ring_distribs,
        auto simp add: insert_commute)
  show ?thesis using False
    by (cases "b=c", cases "a=c", auto simp add: 1 2 3 4)
qed


(*This is generalizable to arbitrary sets.*)
lemma ideal_generated_triple_pair_rewrite:
  assumes i1: "ideal_generated {a, b, c} = ideal_generated {d}"
    and i2: "ideal_generated {a, b} = ideal_generated {d'}"
  shows "ideal_generated{d',c} = ideal_generated {d}"
proof
  have d': "d'  ideal_generated {a,b}" using i2 by (simp add: ideal_generated_in)
  show "ideal_generated {d', c}  ideal_generated {d}"
  proof
    fix x assume x: "x  ideal_generated {d', c}"
    obtain f1 f2 where f: "f1*d' + f2*c = x" using obtain_ideal_generated_pair[OF x] by auto
    obtain g1 g2 where g: "g1*a + g2*b = d'" using obtain_ideal_generated_pair[OF d'] by blast
    have 1: "f1*g1*a + f1*g2*b + f2*c = x"
      using f g local.ring_distribs(1) local.semiring_normalization_rules(18) by auto
    have "x  ideal_generated {a, b, c}"
    proof -
      obtain f where "(i{a,b,c}. f i * i) = f1*g1*a + f1*g2*b + f2*c"
        using sum_three_elements' 1 by blast
      moreover have "ideal_generated {a,b,c} = {y. f. (i{a,b,c}. f i * i) = y}"
        using ideal_explicit2[of "{a,b,c}"] by simp
      ultimately show ?thesis using 1 by auto
    qed
    thus "x  ideal_generated {d}" using i1 by auto
  qed
  show "ideal_generated {d}  ideal_generated {d', c}"
  proof (rule ideal_generated_singleton_subset)
    obtain f1 f2 f3 where f: "f1*a + f2*b + f3*c = d"
    proof -
      have "d  ideal_generated {a,b,c}" using i1  by (simp add: ideal_generated_in)
      from this obtain f where d: "(i{a,b,c}. f i * i) = d"
        using ideal_explicit2[of "{a,b,c}"] by auto
      obtain x y z where "(i{a,b,c}. f i * i) = x * a + y * b + z * c"
        using sum_three_elements by blast
      thus ?thesis using d that by auto
    qed
    obtain k where k: "f1*a + f2*b = k*d'"
    proof -
      have "f1*a + f2*b  ideal_generated{a,b}" using ideal_generated_pair by blast
      also have "... = ideal_generated {d'}" using i2 by simp
      also have "... = {k*d' |k. kUNIV}" using ideal_generated_singleton by auto
      finally show ?thesis using that by auto
    qed
    have "k*d'+f3*c=d" using f k by auto
    thus "d  ideal_generated {d', c}"
      using ideal_generated_pair by blast
  qed (simp)
qed

lemma ideal_generated_dvd:
  assumes i: "ideal_generated {a,b::'a} = ideal_generated{d} "
  and a: "d' dvd a" and b: "d' dvd b"
shows "d' dvd d"
proof -
  obtain p q where "p*a+q*b = d"
    using i ideal_generated_pair_exists by blast
  thus ?thesis using a b by auto
qed

lemma ideal_generated_dvd2:
  assumes i: "ideal_generated S = ideal_generated{d::'a} "
  and "finite S"
  and x: "xS. d' dvd x"
shows "d' dvd d"
  by (metis assms dvd_ideal_generated_singleton ideal_generated_dvd_subset)

end


subsection ‹An equivalent characterization of B\'ezout rings›

text ‹The goal of this subsection is to prove that a ring is B\'ezout ring if and only if every
  finitely generated ideal is principal.›

definition "finitely_generated_ideal I = (ideal I  (S. finite S  ideal_generated S = I))"

context
  assumes "SORT_CONSTRAINT('a::comm_ring_1)"
begin


lemma sum_two_elements':
  fixes d::'a
  assumes s: "(i{a,b}. f i * i) = d"
  obtains p and q where "d = p * a + q * b"
proof (cases "a=b")
  case True
  then show ?thesis
    by (metis (no_types, lifting) add_diff_cancel_left' emptyE finite.emptyI insert_absorb2
        left_diff_distrib' s sum.insert sum_singleton that)
next
  case False
  show ?thesis using s unfolding sum_two_elements[OF False]
    using that by auto
qed

text ‹This proof follows Theorem 6-3 in "First Course in Rings and Ideals" by Burton›

lemma all_fin_gen_ideals_are_principal_imp_bezout:
  assumes all: "I::'a set. finitely_generated_ideal I  principal_ideal I"
  shows "OFCLASS ('a, bezout_ring_class)"
proof (intro_classes)
  fix a b::'a
  obtain d where ideal_d: "ideal_generated {a,b} = ideal_generated {d}"
    using all unfolding finitely_generated_ideal_def
    by (metis finite.emptyI finite_insert ideal_ideal_generated principal_ideal_def)
  have a_in_d: "a  ideal_generated {d}"
    using ideal_d ideal_generated_subset_generator by blast
  have b_in_d: "b  ideal_generated {d}"
    using ideal_d ideal_generated_subset_generator by blast
  have d_in_ab: "d  ideal_generated {a,b}"
    using ideal_d ideal_generated_subset_generator by auto
  obtain f where "(i{a,b}. f i * i) = d" using obtain_sum_ideal_generated[OF d_in_ab] by auto
  from this obtain p q where d_eq: "d = p*a + q*b" using sum_two_elements' by blast
  moreover have d_dvd_a: "d dvd a"
    by (metis dvd_ideal_generated_singleton ideal_d ideal_generated_subset insert_commute
        subset_insertI)
  moreover have "d dvd b"
    by (metis dvd_ideal_generated_singleton ideal_d ideal_generated_subset subset_insertI)
  moreover have "d' dvd d" if d'_dvd: "d' dvd a  d' dvd b" for d'
  proof -
    obtain s1 s2 where s1_dvd: "a = s1*d'" and s2_dvd: "b = s2*d'"
      using mult.commute d'_dvd unfolding dvd_def by auto
    have "d = p*a + q*b" using d_eq .
    also have "...= p * s1 * d' + q * s2 *d'" unfolding s1_dvd s2_dvd by auto
    also have "... = (p * s1 + q * s2) * d'" by (simp add: ring_class.ring_distribs(2))
    finally show "d' dvd d" using mult.commute unfolding dvd_def by auto
  qed
  ultimately show "p q d. p * a + q * b = d  d dvd a  d dvd b
   (d'. d' dvd a  d' dvd b  d' dvd d)" by auto
qed
end


context bezout_ring
begin

lemma exists_bezout_extended:
  assumes S: "finite S" and ne: "S  {}"
  shows "f d. (aS. f a * a) = d  (aS. d dvd a)  (d'. (aS. d' dvd a)  d' dvd d)"
  using S ne
proof (induct S)
  case empty
  then show ?case by auto
next
  case (insert x S)
  show ?case
  proof (cases  "S={}")
    case True
    let ?f = "λx. 1"
    show ?thesis by (rule exI[of _ ?f], insert True, auto)
  next
    case False note ne = False
    note x_notin_S = insert.hyps(2)
    obtain f d where sum_eq_d: "(aS. f a * a) = d"
      and d_dvd_each_a: "(aS. d dvd a)"
      and d_is_gcd: "(d'. (aS. d' dvd a)  d' dvd d)"
      using insert.hyps(3)[OF ne] by auto
    have "p q d'. p * d + q * x = d'  d' dvd d  d' dvd x  (c. c dvd d  c dvd x  c dvd d')"
      using exists_bezout by auto
    from this obtain p q d' where pd_qx_d': "p*d + q*x = d'"
      and d'_dvd_d: "d' dvd d" and d'_dvd_x: "d' dvd x"
      and d'_dvd: "c. (c dvd d  c dvd x)  c dvd d'" by blast
    let ?f = "λa. if a = x then q else p * f a"
    have "(ainsert x S. ?f a * a) = d'"
    proof -
      have "(ainsert x S. ?f a * a) = (aS. ?f a * a) + ?f x * x"
        by (simp add: add_commute insert.hyps(1) insert.hyps(2))
      also have "... = p * (aS. f a * a) + q * x"
        unfolding sum_distrib_left
        by (auto, rule sum.cong, insert x_notin_S,
            auto simp add: mult.semigroup_axioms semigroup.assoc)
      finally show ?thesis using pd_qx_d' sum_eq_d by auto
    qed
    moreover have "(ainsert x S. d' dvd a)"
      by (metis d'_dvd_d d'_dvd_x d_dvd_each_a insert_iff local.dvdE local.dvd_mult_left)
    moreover have " (c. (ainsert x S. c dvd a)  c dvd d')"
      by (simp add: d'_dvd d_is_gcd)
    ultimately show ?thesis by auto
  qed
qed

end

lemma ideal_generated_empty: "ideal_generated {} = {0}"
  unfolding ideal_generated_def using ideal_generated_0
  by (metis empty_subsetI ideal_generated_def ideal_generated_subset ideal_ideal_generated
      ideal_not_empty subset_singletonD)


lemma bezout_imp_all_fin_gen_ideals_are_principal:
  fixes I::"'a :: bezout_ring set"
  assumes fin: "finitely_generated_ideal I"
  shows "principal_ideal I"
proof -
  obtain S where fin_S: "finite S" and ideal_gen_S: "ideal_generated S = I"
    using fin unfolding finitely_generated_ideal_def by auto
  show ?thesis
  proof (cases "S = {}")
    case True
    then show ?thesis
      using ideal_gen_S unfolding True
      using ideal_generated_empty ideal_generated_0 principal_ideal_def by fastforce
  next
    case False note ne = False
    obtain d f where sum_S_d: "(iS. f i * i) = d"
    and d_dvd_a: "(aS. d dvd a)" and d_is_gcd: "(d'. (aS. d' dvd a)  d' dvd d)"
      using exists_bezout_extended[OF fin_S ne] by auto
    have d_in_S: "d  ideal_generated S"
      by (metis fin_S ideal_def ideal_generated_subset_generator
          ideal_ideal_generated sum_S_d sum_left_ideal)
    have "ideal_generated {d}  ideal_generated S"
      by (rule ideal_generated_singleton_subset[OF d_in_S fin_S])
    moreover have "ideal_generated S  ideal_generated {d}"
    proof
      fix x assume x_in_S: "x  ideal_generated S"
      obtain f where sum_S_x: "(aS. f a * a) = x"
        using fin_S obtain_sum_ideal_generated x_in_S by blast
      have d_dvd_each_a: "k. a = k * d" if "a  S" for a
        by (metis d_dvd_a dvdE mult.commute that)
      let ?g = "λa. SOME k. a = k*d"
      have "x = (aS. f a * a)" using sum_S_x by simp
      also have "... = (aS. f a * (?g a * d))"
      proof (rule sum.cong)
        fix a assume a_in_S: "a  S"
        obtain k where a_kd: "a = k * d" using d_dvd_each_a a_in_S by auto
        have "a = ((SOME k. a = k * d) * d)" by (rule someI_ex, auto simp add: a_kd)
        thus "f a * a = f a * ((SOME k. a = k * d) * d)" by auto
      qed (simp)
      also have "... = (aS. f a * ?g a * d)" by (rule sum.cong, auto)
      also have "... = (aS. f a * ?g a)*d" using sum_distrib_right[of _ S d] by auto
      finally show "x  ideal_generated {d}"
        by (meson contra_subsetD dvd_ideal_generated_singleton' dvd_triv_right
            ideal_generated_in singletonI)
    qed
    ultimately show ?thesis unfolding principal_ideal_def using ideal_gen_S by auto
  qed
qed

text ‹Now we have the required lemmas to prove the theorem that states that
  a ring is B\'ezout ring if and only if every
  finitely generated ideal is principal. They are the following ones.

\begin{itemize}
\item @{text "all_fin_gen_ideals_are_principal_imp_bezout"}
\item @{text "bezout_imp_all_fin_gen_ideals_are_principal"}
\end{itemize}

However, in order to prove the final lemma, we need the lemmas with no type restrictions.
For instance, we need a version of theorem @{text "bezout_imp_all_fin_gen_ideals_are_principal"}
as

@{text "OFCLASS('a,bezout_ring) ⟹"} the theorem with generic types
  (i.e., @{text "'a"} with no type restrictions)


or as

@{text "class.bezout_ring _ _ _ _ ⟹"} the theorem with generic
  types (i.e., @{text "'a"} with no type restrictions)
›

(*A possible workaround is to adapt the proof*)
(*
lemma bezout_imp_all_fin_gen_ideals_are_principal_unsatisfactory:
  assumes a1: "class.bezout_ring ( * ) (1::'a::comm_ring_1) (+) 0 (-) uminus" (*Me da igual esto que OFCLASS*)
  shows "∀I::'a set. finitely_generated_ideal I ⟶ principal_ideal I"
proof (rule allI, rule impI)
  fix I::"'a set" assume fin: "finitely_generated_ideal I"
  interpret a: bezout_ring "( * )" "(1::'a)" "(+)" 0 "(-)" uminus using a1 .
  interpret dvd "( * )::'a⇒'a⇒'a" .
  interpret b: comm_monoid_add "(+)" "(0::'a)" using a1 by intro_locales
  have c: " class.comm_monoid_add (+) (0::'a)"  using a1 by intro_locales
  have [simp]: "(dvd.dvd ( * ) d a) = (d dvd a)" for d a::'a
    by (auto simp add: dvd.dvd_def dvd_def)
  have [simp]: "comm_monoid_add.sum (+) 0 (λa. f a * a) S = sum (λa. f a * a) S"
    for f and S::"'a set"
    unfolding sum_def unfolding comm_monoid_add.sum_def[OF c] ..
  obtain S where fin_S: "finite S" and ideal_gen_S: "ideal_generated S = I"
    using fin unfolding finitely_generated_ideal_def by auto
  show "principal_ideal I"
  proof (cases "S = {}")
    case True
    then show ?thesis
      using ideal_gen_S unfolding True
      using ideal_generated_empty ideal_generated_0 principal_ideal_def by fastforce
  next
    case False note ne = False
    obtain d f where sum_S_d: "(∑i∈S. f i * i) = d"
    and d_dvd_a: "(∀a∈S. d dvd a)" and d_is_gcd: "(∀d'. (∀a∈S. d' dvd a) ⟶ d' dvd d)"
      using a.exists_bezout_extended[OF fin_S ne] by auto
    have d_in_S: "d ∈ ideal_generated S"
      by (metis fin_S ideal_def ideal_generated_subset_generator
          ideal_ideal_generated sum_S_d sum_left_ideal)
    have "ideal_generated {d} ⊆ ideal_generated S"
      by (rule ideal_generated_singleton_subset[OF d_in_S fin_S])
    moreover have "ideal_generated S ⊆ ideal_generated {d}"
    proof
      fix x assume x_in_S: "x ∈ ideal_generated S"
      obtain f where sum_S_x: "(∑a∈S. f a * a) = x"
        using fin_S obtain_sum_ideal_generated x_in_S by blast
      have d_dvd_each_a: "∃k. a = k * d" if "a ∈ S" for a
        by (metis d_dvd_a dvdE mult.commute that)
      let ?g = "λa. SOME k. a = k*d"
      have "x = (∑a∈S. f a * a)" using sum_S_x by simp
      also have "... = (∑a∈S. f a * (?g a * d))"
      proof (rule sum.cong)
        fix a assume a_in_S: "a ∈ S"
        obtain k where a_kd: "a = k * d" using d_dvd_each_a a_in_S by auto
        have "a = ((SOME k. a = k * d) * d)" by (rule someI_ex, auto simp add: a_kd)
        thus "f a * a = f a * ((SOME k. a = k * d) * d)" by auto
      qed (simp)
      also have "... = (∑a∈S. f a * ?g a * d)" by (rule sum.cong, auto)
      also have "... = (∑a∈S. f a * ?g a)*d" using sum_distrib_right[of _ S d] by auto
      finally show "x ∈ ideal_generated {d}"
        by (meson contra_subsetD dvd_ideal_generated_singleton' dvd_triv_right
            ideal_generated_in singletonI)
    qed
    ultimately show ?thesis unfolding principal_ideal_def using ideal_gen_S by auto
  qed
qed
*)

text ‹Thanks to local type definitions, we can obtain it automatically by means
  of @{text "internalize-sort"}.›

lemma bezout_imp_all_fin_gen_ideals_are_principal_unsatisfactory:
  assumes a1: "class.bezout_ring (*) (1::'b::comm_ring_1) (+) 0 (-) uminus" (*It is algo possible to prove it using OFCLASS*)
  shows "I::'b set. finitely_generated_ideal I  principal_ideal I"
  using bezout_imp_all_fin_gen_ideals_are_principal[internalize_sort "'a::bezout_ring"]
  using a1 by auto


text ‹The standard library does not connect @{text "OFCLASS"} and @{text "class.bezout_ring"}
in both directions. Here we show that @{text "OFCLASS ⟹ class.bezout_ring"}. ›

lemma OFCLASS_bezout_ring_imp_class_bezout_ring:
  assumes "OFCLASS('a::comm_ring_1,bezout_ring_class)"
  shows "class.bezout_ring ((*)::'a'a'a) 1 (+) 0 (-) uminus"
  using assms
  unfolding bezout_ring_class_def class.bezout_ring_def
  using conjunctionD2[of "OFCLASS('a, comm_ring_1_class)"
                         "class.bezout_ring_axioms ((*)::'a'a'a) (+)"]
  by (auto, intro_locales)

text ‹The other implication can be obtained
  by thm @{text "Rings2.class.Rings2.bezout_ring.of_class.intro"}
thm Rings2.class.Rings2.bezout_ring.of_class.intro


(*OFCLASS is a proposition (Prop), and then the following statement is not valid.*)

(*
lemma
  shows "(∀I::'a::comm_ring_1 set. finitely_generated_ideal I ⟶ principal_ideal I)
    = OFCLASS('a, bezout_ring_class)"
*)

(*Thus, we use the meta-equality and the meta universal quantifier.*)
text ‹Final theorem (with OFCLASS)›
lemma bezout_ring_iff_fin_gen_principal_ideal:
    "(I::'a::comm_ring_1 set. finitely_generated_ideal I  principal_ideal I)
     OFCLASS('a, bezout_ring_class)"
proof
  show "(I::'a::comm_ring_1 set. finitely_generated_ideal I  principal_ideal I)
     OFCLASS('a, bezout_ring_class)"
    using all_fin_gen_ideals_are_principal_imp_bezout [where ?'a='a] by auto
  show "I::'a::comm_ring_1 set. OFCLASS('a, bezout_ring_class)
     finitely_generated_ideal I  principal_ideal I"
    using bezout_imp_all_fin_gen_ideals_are_principal_unsatisfactory[where ?'b='a]
    using OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a='a] by auto
qed

text ‹Final theorem (with @{text "class.bezout_ring"})›

lemma bezout_ring_iff_fin_gen_principal_ideal2:
    "(I::'a::comm_ring_1 set. finitely_generated_ideal I  principal_ideal I)
    = (class.bezout_ring ((*)::'a'a'a) 1 (+) 0 (-) uminus)"
proof
  show "I::'a::comm_ring_1 set. finitely_generated_ideal I  principal_ideal I
       class.bezout_ring (*) 1 (+) (0::'a) (-) uminus"
    using all_fin_gen_ideals_are_principal_imp_bezout[where ?'a='a]
    using OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a='a]
    by auto
  show "class.bezout_ring (*) 1 (+) (0::'a) (-) uminus  I::'a set.
    finitely_generated_ideal I  principal_ideal I"
    using bezout_imp_all_fin_gen_ideals_are_principal_unsatisfactory by auto
qed

end

Theory Finite_Field_Mod_Type_Connection

(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section ‹Connection between @{text "mod_ring"} and @{text "mod_type"}

text ‹This file shows that the type @{text "mod_ring"}, which is defined in the 
  Berlekamp--Zassenhaus development, is an instantiation of the type class @{text "mod_type"}.›

theory Finite_Field_Mod_Type_Connection
  imports
  Berlekamp_Zassenhaus.Finite_Field
  Rank_Nullity_Theorem.Mod_Type
begin

instantiation mod_ring :: (finite) ord
begin
definition less_eq_mod_ring :: "'a mod_ring  'a mod_ring  bool" 
  where "less_eq_mod_ring x y = (to_int_mod_ring x  to_int_mod_ring y)"

definition less_mod_ring :: "'a mod_ring  'a mod_ring  bool" 
  where "less_mod_ring x y = (to_int_mod_ring x < to_int_mod_ring y)"

instance proof qed
end

instantiation mod_ring :: (finite) linorder
begin
instance by (intro_classes, unfold less_eq_mod_ring_def less_mod_ring_def) (transfer, auto)
end


instance mod_ring :: (finite) wellorder
proof -
have "wf {(x :: 'a mod_ring, y). x < y}"
    by (auto simp add: trancl_def tranclp_less intro!: finite_acyclic_wf acyclicI)
  thus "OFCLASS('a mod_ring, wellorder_class)"
    by(rule wf_wellorderI) intro_classes
qed


lemma strict_mono_to_int_mod_ring: "strict_mono to_int_mod_ring"
  unfolding strict_mono_def unfolding less_mod_ring_def by auto


instantiation mod_ring :: (nontriv) mod_type
begin
definition Rep_mod_ring :: "'a mod_ring  int"
  where "Rep_mod_ring x = to_int_mod_ring x"

definition Abs_mod_ring :: "int  'a mod_ring"
  where "Abs_mod_ring x = of_int_mod_ring x"

instance 
proof (intro_classes)
  show "type_definition (Rep::'a mod_ring  int) Abs {0..<int CARD('a mod_ring)}"
    unfolding Rep_mod_ring_def Abs_mod_ring_def type_definition_def by (transfer, auto) 
  show "1 < int CARD('a mod_ring)" using less_imp_of_nat_less nontriv by fastforce
  show "0 = (Abs::int  'a mod_ring) 0"
    by (simp add: Abs_mod_ring_def)
  show "1 = (Abs::int  'a mod_ring) 1"
    by (metis (mono_tags, hide_lams) Abs_mod_ring_def of_int_hom.hom_one of_int_of_int_mod_ring)
  fix x y::"'a mod_ring"
  show "x + y = Abs ((Rep x + Rep y) mod int CARD('a mod_ring))"
    unfolding Abs_mod_ring_def Rep_mod_ring_def by (transfer, auto)
  show "- x = Abs (- Rep x mod int CARD('a mod_ring))" 
    unfolding Abs_mod_ring_def Rep_mod_ring_def by (transfer, auto simp add: zmod_zminus1_eq_if)
  show "x * y = Abs (Rep x * Rep y mod int CARD('a mod_ring))"
    unfolding Abs_mod_ring_def Rep_mod_ring_def by (transfer, auto)
  show "x - y = Abs ((Rep x - Rep y) mod int CARD('a mod_ring))"
    unfolding Abs_mod_ring_def Rep_mod_ring_def by (transfer, auto)
  show "strict_mono (Rep::'a mod_ring  int)" unfolding Rep_mod_ring_def 
    by (rule strict_mono_to_int_mod_ring)
qed
end
end

Theory Admits_SNF_From_Diagonal_Iff_Bezout_Ring

(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section ‹Generality of the Algorithm to transform from diagonal to Smith normal form›

theory Admits_SNF_From_Diagonal_Iff_Bezout_Ring
  imports   
  Diagonal_To_Smith
  Rings2_Extended
  Smith_Normal_Form_JNF
  Finite_Field_Mod_Type_Connection
begin

hide_const (open) mat

text ‹This section provides a formal proof on the generality of the algorithm that transforms
a diagonal matrix into its Smith normal form. More concretely, we prove that 
all diagonal matrices with coefficients in a ring R admit Smith normal form if and only if
R is a B\'ezout ring.

Since our algorithm is defined for B\'ezout rings and for any matrices (including non-square and
singular ones), this means that it does not exist another algorithm that performs the transformation
in a more abstract structure.›

text ‹Firstly, we hide some definitions and facts, since we are interested in the ones 
developed for the @{text "mod_type"} class.›

hide_const (open) Bij_Nat.to_nat Bij_Nat.from_nat Countable.to_nat Countable.from_nat 
hide_fact (open) Bij_Nat.to_nat_from_nat_id Bij_Nat.to_nat_less_card

definition "admits_SNF_HA (A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}) = (isDiagonal A 
     (P Q. invertible ((P::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type})) 
         invertible (Q::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type})  Smith_normal_form (P**A**Q)))"

definition "admits_SNF_JNF A = (square_mat (A::'a::comm_ring_1 mat)  isDiagonal_mat A 
   (P Q. P  carrier_mat (dim_row A) (dim_row A)  Q  carrier_mat (dim_row A) (dim_row A) 
     invertible_mat P  invertible_mat Q  Smith_normal_form_mat (P*A*Q)))"


subsection ‹Proof of the  @{text "⟸"} implication in HA.›

lemma exists_f_PAQ_Aii':
  fixes A::"'a::{comm_ring_1}^'n::{mod_type}^'n::{mod_type}"
  assumes diag_A: "isDiagonal A"
  shows "f. (P**A**Q) $h i $h i = (i(UNIV::'n set). f i * A $h i $h i)" 
proof -  
  have rw: "(kaUNIV. P $h i $h ka * A $h ka $h k) = P $h i $h k * A $h k $h k" for k
  proof -
    have "(kaUNIV. P $h i $h ka * A $h ka $h k) = (ka{k}. P $h i $h ka * A $h ka $h k)" 
    proof (rule sum.mono_neutral_right, auto)
      fix ia assume "P $h i $h ia * A $h ia $h k  0" 
      hence "A $h ia $h k  0" by auto
      thus" ia = k" using diag_A unfolding isDiagonal_def by auto  
    qed
    also have "... = P $h i $h k * A $h k $h k" by auto
    finally show ?thesis .
  qed
  let ?f = "λk. (kaUNIV. P $h i $h ka) * Q $h k $h i"
  have "(P**A**Q) $h i $h i = (kUNIV. (kaUNIV. P $h i $h ka * A $h ka $h k) * Q $h k $h i)" 
    unfolding matrix_matrix_mult_def by auto  
  also have "... = (kUNIV.  P $h i $h k * Q $h k $h i * A $h k $h k)" 
    unfolding rw
    by (meson semiring_normalization_rules(16))
  finally show ?thesis by auto
qed

(*We would like to have the theorems within contexts:

context semiring_1
begin

lemma foo1:
  fixes foo::"'a::type⇒'a⇒'a"
  shows "foo a = c"
  sorry

end

where 'a has simply type "type". This way, we could have 
thm semiring_1.foo

Which is: class.semiring_1 ?one ?times ?plus ?zero ⟹ ?foo ?a = ?c

However, many of them are proven with type restrictions instead of being proved within a context.
For example:

lemma foo2:
  fixes foo::"'a::semiring_1⇒'a⇒'a"
  shows "foo a = c" sorry

To convert foo2 to a statement like foo1, we need interalize_sort developed in From Types to Sets.

lemmas foo2 = foo1[internalize_sort "'a :: semiring_1"]
*)

text ‹We apply @{text "internalize_sort"} to the lemma that we need›

lemmas diagonal_to_Smith_PQ_exists_internalize_sort 
  = diagonal_to_Smith_PQ_exists[internalize_sort "'a :: bezout_ring"]

text ‹We get the @{text "⟸"} implication in HA.›

lemma bezout_ring_imp_diagonal_admits_SNF:
  assumes of: "OFCLASS('a::comm_ring_1, bezout_ring_class)"
  shows "A::'a^'n::{mod_type}^'n::{mod_type}. isDiagonal A 
     (P Q. 
        invertible (P::'a^'n::mod_type^'n::mod_type)  
        invertible (Q::'a^'n::mod_type^'n::mod_type)  
        Smith_normal_form (P**A**Q))"
proof (rule allI, rule impI)
  fix A::"'a^'n::{mod_type}^'n::{mod_type}"
  assume A: "isDiagonal A" 
  have br: "class.bezout_ring (*) (1::'a) (+) 0 (-) uminus" 
    by (rule OFCLASS_bezout_ring_imp_class_bezout_ring[OF of])   
  show "P Q. 
        invertible (P::'a^'n::mod_type^'n::mod_type)  
        invertible (Q::'a^'n::mod_type^'n::mod_type)  
        Smith_normal_form (P**A**Q)" by (rule diagonal_to_Smith_PQ_exists_internalize_sort[OF br A])
qed

subsection ‹Trying to prove the @{text "⟹"} implication in HA.›

text‹There is a problem: we need to define a matrix with a concrete dimension, which is not 
  possible in HA (the dimension depends on the number of elements on a set, and Isabelle/HOL does
  not feature dependent types)›

lemma
  assumes "A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. admits_SNF_HA A"
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class)" oops

(*
lemma   
  assumes "∀A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. isDiagonal A 
    ⟶ (∃P Q. invertible P ∧ invertible Q ∧ Smith_normal_form (P**A**Q))"
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class)"
proof (rule all_fin_gen_ideals_are_principal_imp_bezout, rule allI, rule impI)
  fix I::"'a set"
  assume fin: "finitely_generated_ideal I"
  obtain S where ig_S: "ideal_generated S = I" and fin_S: "finite S" 
    using fin unfolding finitely_generated_ideal_def by auto
  obtain xs where set_xs: "set xs = S" and d: "distinct xs" 
    using finite_distinct_list[OF fin_S] by blast
  hence length_eq_card: "length xs = card S" using distinct_card by force
(*
  The proof requires:
  1) Obtain a matrix A whose diagonal entries are the elements of xs
  2) Transform such a matrix A into its Smith normal form by means of elementary operations
  3) Put the diagonal entries of the matrix in Smith normal form as a list ys.
  4) Proof that the first element of ys divides all the other elements of such a list.
  5) Show that, ideal_generated (set xs) = ideal_generated (set ys) = ideal_generated (ys!0).
*)
  show "principal_ideal I"

qed

(*Alternative statement (same problems)*)

lemma   
  assumes "∀A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. admits_SNF_HA A"
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class)" oops
*)


subsection ‹Proof of the  @{text "⟹"}  implication in JNF.›

lemma exists_f_PAQ_Aii:
  assumes diag_A: "isDiagonal_mat (A::'a:: comm_ring_1 mat)" 
    and P: "P  carrier_mat n n" 
    and A: "A  carrier_mat n n" 
    and Q: "Q  carrier_mat n n" 
    and i: "i < n" 
  (*  and d: "distinct (diag_mat A)" (*With some work, this assumption can be removed.*)*)
  shows "f. (P*A*Q) $$ (i, i) = (iset (diag_mat A). f i * i)" 
proof -
  let ?xs = "diag_mat A"
  let ?n = "length ?xs"
  have length_n: "length (diag_mat A) = n"
    by (metis A carrier_matD(1) diag_mat_def diff_zero length_map length_upt)
  have xs_index: "?xs ! i = A $$ (i, i)" if "i<n" for i
    by (metis (no_types, lifting) add.left_neutral diag_mat_def length_map 
        length_n length_upt nth_map_upt that)
  have i_length: "i<length ?xs" using i length_n by auto
  have rw: "(ka = 0..<?n. P $$ (i, ka) * A $$ (ka, k)) = P $$(i, k) * A $$ (k, k)" 
    if k: "k<length ?xs" for k
  proof -
    have "(ka= 0..<?n. P $$ (i, ka) * A $$ (ka, k)) = (ka{k}. P $$ (i, ka) * A $$ (ka, k))" 
      by (rule sum.mono_neutral_right, auto simp add: k, 
          insert diag_A A length_n that, unfold isDiagonal_mat_def, fastforce)            
    also have "... = P $$(i, k) * A $$ (k, k)" by auto
    finally show ?thesis .
  qed
  let ?positions_of ="λx. {i. A$$(i,i) = x  i<length ?xs}"
  let ?T="set ?xs"
  let ?S ="{0..<?n}"
  let ?f = "λx.(k{i. A $$ (i, i) = x  i < length (diag_mat A)}. P $$ (i, k) * Q $$ (k, i))"
  let ?g = "(λk. P $$ (i,k) * Q $$ (k, i) * A $$ (k, k))"
  have UNION_positions_of: "(?positions_of ` ?T) = ?S" unfolding diag_mat_def by auto
  have "(P*A*Q) $$ (i,i) = (ia = 0..<?n.
        Matrix.row (Matrix.mat ?n ?n (λ(i, j). ia = 0..<?n. 
        Matrix.row P i $v ia * col A j $v ia)) i $v ia * col Q i $v ia)" 
    unfolding times_mat_def scalar_prod_def 
    using P Q i_length length_n A by auto
  also have "... = (k = 0..<?n. (ka = 0..<?n. P$$(i,ka) * A$$(ka,k)) * Q $$ (k,i))"
  proof (rule sum.cong, auto)
    fix x assume x: "x < length ?xs" 
    have rw_colQ: "col Q i $v x = Q $$ (x, i)"
      using Q i_length x length_n A by auto
    have rw2: " Matrix.row (Matrix.mat ?n ?n
            (λ(i, j). ia = 0..<length ?xs. Matrix.row P i $v ia * col A j $v ia)) i $v x 
            =(ia = 0..<length ?xs. Matrix.row P i $v ia * col A x $v ia)"
      unfolding row_mat[OF i_length] unfolding index_vec[OF x] by auto
    also have "... = (ia = 0..<length ?xs.  P $$ (i,ia) * A $$ (ia,x))" 
      by (rule sum.cong, insert P i_length x length_n A, auto)
    finally show "Matrix.row (Matrix.mat ?n ?n (λ(i, j). ia = 0..<?n. Matrix.row P i $v ia 
            * col A j $v ia)) i $v x * col Q i $v x 
            = (ka = 0..<?n. P $$ (i, ka) * A $$ (ka, x)) * Q $$ (x, i)" unfolding rw_colQ by auto
  qed       
  also have "... = (k = 0..<?n. P $$ (i,k) * Q $$ (k, i) * A $$ (k, k))"
    by (smt rw semiring_normalization_rules(16) sum.ivl_cong)
  also have "... = sum ?g ((?positions_of ` ?T))" 
    using UNION_positions_of by auto
  also have "... = (x?T. sum ?g (?positions_of x))"
    by (rule sum.UNION_disjoint, auto)
  also have "... = (xset (diag_mat A). (k{i. A $$ (i, i) = x  i < length (diag_mat A)}. 
    P $$ (i, k) * Q $$ (k, i)) * x)"
    by (rule sum.cong, auto simp add: Groups_Big.sum_distrib_right)  
  finally show ?thesis by auto
qed

text ‹Proof of the @{text "⟹"} implication in JNF.›

lemma diagonal_admits_SNF_imp_bezout_ring_JNF:
  assumes admits_SNF: "A n. (A::'a mat)  carrier_mat n n  isDiagonal_mat A
   (P Q. P  carrier_mat n n  Q  carrier_mat n n  invertible_mat P  invertible_mat Q 
       Smith_normal_form_mat (P*A*Q))"
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class)"
proof (rule all_fin_gen_ideals_are_principal_imp_bezout, rule allI, rule impI)
  fix I::"'a set"
  assume fin: "finitely_generated_ideal I"
  obtain S where ig_S: "ideal_generated S = I" and fin_S: "finite S" 
    using fin unfolding finitely_generated_ideal_def by auto
  show "principal_ideal I"
  proof (cases "S = {}")
    case True
    then show ?thesis
      by (metis ideal_generated_0 ideal_generated_empty ig_S principal_ideal_def)
  next
    case False    
    obtain xs where set_xs: "set xs = S" and d: "distinct xs" 
      using finite_distinct_list[OF fin_S] by blast
    hence length_eq_card: "length xs = card S" using distinct_card by force
    let ?n = "length xs"
    let ?A = "Matrix.mat ?n ?n (λ(a,b). if a = b then xs!a else 0)"
    have A_carrier: "?A  carrier_mat ?n ?n" by auto
    have diag_A: "isDiagonal_mat ?A" unfolding isDiagonal_mat_def by auto
    have set_xs_eq: "set xs = {?A$$(i,i)| i. i<dim_row ?A}"
      by (auto, smt case_prod_conv d distinct_Ex1 index_mat(1))
    have set_xs_diag_mat: "set xs = set (diag_mat ?A)" 
      using set_xs_eq unfolding diag_mat_def by auto
    obtain P Q where P: "P  carrier_mat ?n ?n" 
      and Q: "Q  carrier_mat ?n ?n" and inv_P: "invertible_mat P" and inv_Q: "invertible_mat Q"
      and SNF_PAQ: "Smith_normal_form_mat (P*?A*Q)" 
      using admits_SNF A_carrier diag_A by blast
    define ys where ys_def: "ys = diag_mat (P*?A*Q)" 
    have ys: "i<?n. ys ! i = (P*?A*Q) $$ (i,i)" using P by (auto simp add: ys_def diag_mat_def)
    have length_ys: "length ys = ?n" unfolding ys_def
      by (metis (no_types, lifting) P carrier_matD(1) diag_mat_def 
          index_mult_mat(2) length_map map_nth)    
    have n0: "?n > 0" using False set_xs by blast
    have set_ys_diag_mat: "set ys = set (diag_mat (P*?A*Q))" using ys_def by auto
    let ?i = "ys ! 0"
    have dvd_all: "a  set ys. ?i dvd a"
    proof    
      fix a assume a: "a  set ys"
      obtain j where ys_j_a: "ys ! j = a" and jn: "j<?n" by (metis a in_set_conv_nth length_ys) 
      have jP: "j < dim_row P" using jn P by auto
      have jQ: "j < dim_col Q" using jn Q by auto
      have "(P*?A*Q)$$(0,0) dvd (P*?A*Q)$$(j,j)"
        by (rule SNF_first_divides[OF SNF_PAQ], auto simp add: jP jQ)
      thus "ys ! 0 dvd a" using ys length_ys ys_j_a jn n0 by auto
    qed
    have "ideal_generated S = ideal_generated (set xs)" using set_xs by simp
    also have "... = ideal_generated (set ys)"
    proof
      show "ideal_generated (set xs)  ideal_generated (set ys)"
      proof (rule ideal_generated_subset2, rule ballI)
        fix b assume b: "b  set xs"
        obtain i where b_A_ii: "b = ?A $$ (i,i)" and i_length: "i<length xs" 
          using b set_xs_eq by auto
        obtain P' where inverts_mat_P': "inverts_mat P P'  inverts_mat P' P" 
          using inv_P unfolding invertible_mat_def by auto
        have P': "P'  carrier_mat ?n ?n" 
          using inverts_mat_P' 
          unfolding carrier_mat_def inverts_mat_def
          by (auto,metis P carrier_matD index_mult_mat(3) one_carrier_mat)+
        obtain Q' where inverts_mat_Q': "inverts_mat Q Q'  inverts_mat Q' Q"
          using inv_Q unfolding invertible_mat_def by auto
        have Q': "Q'  carrier_mat ?n ?n" 
          using inverts_mat_Q'
          unfolding carrier_mat_def inverts_mat_def
          by (auto,metis Q carrier_matD index_mult_mat(3) one_carrier_mat)+
        have rw_PAQ: "(P'*(P*?A*Q)*Q') $$ (i, i) = ?A $$ (i,i)"
          using inv_P'PAQQ'[OF A_carrier P _ _ Q P' Q'] inverts_mat_P' inverts_mat_Q' by auto
        have diag_PAQ: "isDiagonal_mat (P*?A*Q)" 
          using SNF_PAQ unfolding Smith_normal_form_mat_def by auto
        have PAQ_carrier: "(P*?A*Q)  carrier_mat ?n ?n" using P Q by auto
        obtain f where f: "(P'*(P*?A*Q)*Q') $$ (i, i) = (iset (diag_mat (P*?A*Q)). f i * i)"
          using exists_f_PAQ_Aii[OF diag_PAQ P' PAQ_carrier Q' i_length] by auto
        hence "?A $$ (i,i) = (iset (diag_mat (P*?A*Q)). f i * i)" unfolding rw_PAQ .
        thus "b ideal_generated (set ys)"
          unfolding ideal_explicit using set_ys_diag_mat b_A_ii by auto
      qed      
      show "ideal_generated (set ys)  ideal_generated (set xs)"
      proof (rule ideal_generated_subset2, rule ballI)
        fix b assume b: "b  set ys"
        have d: "distinct (diag_mat ?A)"
          by (metis (no_types, lifting) A_carrier card_distinct carrier_matD(1) diag_mat_def 
             length_eq_card length_map map_nth set_xs set_xs_diag_mat)
        obtain i where b_PAQ_ii: "(P*?A*Q) $$ (i,i) = b" and i_length: "i<length xs" using b ys
          by (metis (no_types, lifting) in_set_conv_nth length_ys)
        obtain f where "(P * ?A * Q) $$ (i, i) = (iset (diag_mat ?A). f i * i)" 
          using exists_f_PAQ_Aii[OF diag_A P _ Q i_length] by auto
        thus "b  ideal_generated (set xs)" 
          using b_PAQ_ii unfolding set_xs_diag_mat ideal_explicit by auto
      qed
    qed
    also have "... = ideal_generated (set ys - (set ys - {ys!0}))"
    proof (rule ideal_generated_dvd_eq_diff_set)
      show "?i  set ys" using n0
        by (simp add: length_ys)
      show "?i  set ys - {?i}" by auto
      show "jset ys - {?i}. ?i dvd j" using dvd_all by auto 
      show "finite (set ys - {?i})" by auto
    qed
    also have "... = ideal_generated {?i}"
      by (metis Diff_cancel Diff_not_in insert_Diff insert_Diff_if length_ys n0 nth_mem)
    finally show "principal_ideal I" unfolding principal_ideal_def using ig_S by auto
  qed
qed



(*Alternative statement:*)
corollary diagonal_admits_SNF_imp_bezout_ring_JNF_alt:
  assumes admits_SNF: "A. square_mat (A::'a mat)  isDiagonal_mat A 
 (P Q. P  carrier_mat (dim_row A) (dim_row A) 
   Q  carrier_mat (dim_row A) (dim_row A)  invertible_mat P  invertible_mat Q 
   Smith_normal_form_mat (P*A*Q))"
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class)"
proof (rule diagonal_admits_SNF_imp_bezout_ring_JNF, rule allI, rule allI, rule impI)
  fix A::"'a mat" and n assume A: "A  carrier_mat n n  isDiagonal_mat A"
  have "square_mat A" using A by auto
  thus "P Q. P  carrier_mat n n  Q  carrier_mat n n 
   invertible_mat P  invertible_mat Q  Smith_normal_form_mat (P * A * Q)" 
    using A admits_SNF by blast
qed


subsection ‹Trying to transfer the @{text "⟹"} implication to HA.›

text ‹We first hide some constants defined in @{text "Mod_Type_Connect"} in order to use the ones
presented in @{text "Perron_Frobenius.HMA_Connect"} by default.›


context 
  includes lifting_syntax
begin

lemma to_nat_mod_type_Bij_Nat:
  fixes a::"'n::mod_type"
  obtains b::'n where "mod_type_class.to_nat a = Bij_Nat.to_nat b"
  using Bij_Nat.to_nat_from_nat_id mod_type_class.to_nat_less_card by metis

lemma inj_on_Bij_nat_from_nat: "inj_on (Bij_Nat.from_nat::nat  'a) {0..<CARD('a::finite)}"  
  by (auto simp add: inj_on_def Bij_Nat.from_nat_def length_univ_list_card 
      nth_eq_iff_index_eq univ_list(1))

text ‹This lemma only holds if $a$ and $b$ have the same type. Otherwise, 
  it is possible that @{text "Bij_Nat.to_nat a = Bij_Nat.to_nat b"}

lemma Bij_Nat_to_nat_neq:
  fixes a b ::"'n::mod_type"
  assumes "to_nat a  to_nat b"
  shows "Bij_Nat.to_nat a  Bij_Nat.to_nat b"  
  using assms to_nat_inj by blast

text ‹The following proof (a transfer rule for diagonal matrices) 
  is weird, since it does not hold 
  @{text "Bij_Nat.to_nat a = mod_type_class.to_nat a"}. 

  At first, it seems possible to obtain the element $a'$ that satisfies 
   @{text "Bij_Nat.to_nat a' = mod_type_class.to_nat a"} and then continue with the proof, but then
  we cannot prove @{text "HMA_I (Bij_Nat.to_nat a') a"}.

  This means that we must use the previous lemma @{text "Bij_Nat_to_nat_neq"}, but this imposes the 
  matrix to be square.
  ›

lemma HMA_isDiagonal[transfer_rule]: "(HMA_M ===> (=)) 
  isDiagonal_mat (isDiagonal::('a::{zero}^'n::{mod_type}^'n::{mod_type} => bool))"
proof (intro rel_funI, goal_cases)
  case (1 x y)
  note rel_xy [transfer_rule] = "1"
  have "y $h a $h b = 0"
    if all0: "i j. i  j  i < dim_row x  j < dim_col x  x $$ (i, j) = 0"
      and a_noteq_b: "a  b" for a::'n and b::'n
  proof -
    have "to_nat a  to_nat b" using a_noteq_b by auto
    hence distinct: "Bij_Nat.to_nat a  Bij_Nat.to_nat b" by (rule Bij_Nat_to_nat_neq)
    moreover have "Bij_Nat.to_nat a < dim_row x" and "Bij_Nat.to_nat b < dim_col x"
      using Bij_Nat.to_nat_less_card dim_row_transfer_rule rel_xy dim_col_transfer_rule 
      by fastforce+
    ultimately have b: "x $$ (Bij_Nat.to_nat a, Bij_Nat.to_nat b) = 0" using all0 by auto
    have [transfer_rule]: "HMA_I (Bij_Nat.to_nat a) a" by (simp add: HMA_I_def)
    have [transfer_rule]: "HMA_I (Bij_Nat.to_nat b) b" by (simp add: HMA_I_def)
    have "index_hma y a b = 0" using b by (transfer', auto)
    thus ?thesis unfolding index_hma_def .
  qed
  moreover have "x $$ (i, j) = 0" 
    if all0: "a b. a  b  y $h a $h b = 0"
      and ij: "i  j" and i: "i < dim_row x" and j: "j < dim_col x" for i j
  proof -
    have i_n: "i < CARD('n)" and j_n: "j < CARD('n)"
      using i j rel_xy dim_row_transfer_rule dim_col_transfer_rule
      by fastforce+
    let ?i' = "Bij_Nat.from_nat i::'n"
    let ?j' = "Bij_Nat.from_nat j::'n"
    have i'_neq_j': "?i'  ?j'" using ij i_n j_n Bij_Nat.from_nat_inj by blast
    hence y0: "index_hma y ?i' ?j' = 0" using all0 unfolding index_hma_def by auto    
    have [transfer_rule]: "HMA_I i ?i'" unfolding HMA_I_def
      by (simp add: Bij_Nat.to_nat_from_nat_id i_n)
    have [transfer_rule]: "HMA_I j ?j'" unfolding HMA_I_def
      by (simp add: Bij_Nat.to_nat_from_nat_id j_n)
    show ?thesis using y0 by (transfer, auto)
  qed
  ultimately show ?case unfolding isDiagonal_mat_def isDiagonal_def
    by auto
qed

text ‹Indeed, we can prove the transfer rules with the new connection based on the 
  @{text "mod_type"} class, which was developed in the  @{text "Mod_Type_Connect"} file›

text ‹This is the same lemma as the one presented above, but now using the @{text "to_nat"} function
  defined in the  @{text "mod_type"} class and then we can prove it for non-square matrices, 
  which is very useful since our algorithms are not restricted to square matrices.›


lemma HMA_isDiagonal_Mod_Type[transfer_rule]: "(Mod_Type_Connect.HMA_M ===> (=)) 
  isDiagonal_mat (isDiagonal::('a::{zero}^'n::{mod_type}^'m::{mod_type} => bool))"
proof (intro rel_funI, goal_cases)
  case (1 x y)
  note rel_xy [transfer_rule] = "1"
  have "y $h a $h b = 0"
    if all0: "i j. i  j  i < dim_row x  j < dim_col x  x $$ (i, j) = 0"
      and a_noteq_b: "to_nat a  to_nat b" for a::'m and b::'n
  proof -
    have distinct: "to_nat a  to_nat b" using a_noteq_b by auto
    moreover have "to_nat a < dim_row x" and "to_nat b < dim_col x"
      using to_nat_less_card rel_xy 
      using Mod_Type_Connect.dim_row_transfer_rule Mod_Type_Connect.dim_col_transfer_rule 
      by fastforce+
    ultimately have b: "x $$ (to_nat a, to_nat b) = 0" using all0 by auto
    have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat a) a" 
      by (simp add: Mod_Type_Connect.HMA_I_def)
    have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat b) b" 
      by (simp add: Mod_Type_Connect.HMA_I_def)
    have "index_hma y a b = 0" using b by (transfer', auto)
    thus ?thesis unfolding index_hma_def .
  qed
  moreover have "x $$ (i, j) = 0" 
    if all0: "a b. to_nat a  to_nat b  y $h a $h b = 0"
      and ij: "i  j" and i: "i < dim_row x" and j: "j < dim_col x" for i j
  proof -
    have i_n: "i < CARD('m)"
      using i rel_xy by (simp add: Mod_Type_Connect.dim_row_transfer_rule)
    have j_n: "j < CARD('n)"
      using j rel_xy by (simp add: Mod_Type_Connect.dim_col_transfer_rule)
    let ?i' = "from_nat i::'m"
    let ?j' = "from_nat j::'n"
    have "to_nat ?i'  to_nat ?j'"
      by (simp add: i_n ij j_n mod_type_class.to_nat_from_nat_id)
    hence y0: "index_hma y ?i' ?j' = 0" using all0 unfolding index_hma_def by auto
    have [transfer_rule]: "Mod_Type_Connect.HMA_I i ?i'" 
      unfolding Mod_Type_Connect.HMA_I_def
      by (simp add: to_nat_from_nat_id i_n)
    have [transfer_rule]: "Mod_Type_Connect.HMA_I j ?j'" 
      unfolding Mod_Type_Connect.HMA_I_def
      by (simp add: to_nat_from_nat_id j_n)
    show ?thesis using y0 by (transfer, auto)
  qed
  ultimately show ?case unfolding isDiagonal_mat_def isDiagonal_def
    by auto
qed


(*We cannot state:

 lemma HMA_SNF[transfer_rule]: "(HMA_M ===> (=)) Smith_normal_form_mat
  (Smith_normal_form::'a::{comm_ring_1}^'n::{mod_type}^'n::{mod_type}⇒bool)"

Since we need properties about Suc (Bij_Nat.to_nat a). This means that is mandatory to use
a bridge that relates the JNF representation with the HA one based on indexes with the mod_type
class restriction. This is carried out in the file Mod_Type_Connect.

Otherwise, I cannot relate 

x $$ (to_nat a, to_nat a) dvd x $$ (to_nat (a + 1), to_nat (a + 1))

with

y $h a $h a dvd y $h (a + 1) $h (a + 1) 

being such to_nat the one presented in Mod_Type, which is not the same as Bij_Nat.to_nat 
(mod_type_class.to_nat satisfies more properties that easier the definitions and proofs, 
and indeed are fundamental for defining the Smith normal form).
*)

text‹We state the transfer rule using the relations developed in the new bride of the file
    @{text "Mod_Type_Connect"}.›

lemma HMA_SNF[transfer_rule]: "(Mod_Type_Connect.HMA_M ===> (=)) Smith_normal_form_mat 
(Smith_normal_form::'a::{comm_ring_1}^'n::{mod_type}^'m::{mod_type}bool)"
proof (intro rel_funI, goal_cases)
  case (1 x y)
  note rel_xy[transfer_rule] = "1"
  have "y $h a $h b dvd y $h (a + 1) $h (b + 1)"
    if SNF_condition: "a. Suc a < dim_row x  Suc a < dim_col x 
       x $$ (a, a) dvd x $$ (Suc a, Suc a)"
      and a1: "Suc (to_nat a) < nrows y" and a2: "Suc (to_nat b) < ncols y"
      and ab: "to_nat a = to_nat b" for a::'m and b::'n      
  proof -
    have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat a) a" 
      by (simp add: Mod_Type_Connect.HMA_I_def)
    have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat (a+1)) (a+1)" 
      by (simp add: Mod_Type_Connect.HMA_I_def)
    have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat b) b" 
      by (simp add: Mod_Type_Connect.HMA_I_def)
    have [transfer_rule]: "Mod_Type_Connect.HMA_I (to_nat (b+1)) (b+1)" 
      by (simp add: Mod_Type_Connect.HMA_I_def)
    have "Suc (to_nat a) < dim_row x" using a1
      by (metis Mod_Type_Connect.dim_row_transfer_rule nrows_def rel_xy)    
    moreover have "Suc (to_nat b) < dim_col x"
      by (metis Mod_Type_Connect.dim_col_transfer_rule a2 ncols_def rel_xy)
    ultimately have "x $$ (to_nat a, to_nat b) dvd x $$ (Suc (to_nat a), Suc (to_nat b))"
      using SNF_condition by (simp add: ab)
    also have "... = x $$ (to_nat (a+1), to_nat (b+1))"
      by (metis Suc_eq_plus1 a1 a2 nrows_def ncols_def to_nat_suc)
    finally have SNF_cond: "x $$ (to_nat a, to_nat b) dvd x $$ (to_nat (a + 1), to_nat (b + 1))" .    
    have "x $$ (to_nat a, to_nat b) = index_hma y a b" by (transfer, simp)
    moreover have "x $$ (to_nat (a + 1), to_nat (b + 1)) = index_hma y (a+1) (b+1)"
      by (transfer, simp)
    ultimately show ?thesis using SNF_cond unfolding index_hma_def by auto
  qed
  moreover have  "x $$ (a, a) dvd x $$ (Suc a, Suc a)"
    if SNF: "a b. to_nat a = to_nat b  Suc (to_nat a) < nrows y  Suc (to_nat b) < ncols y
         y $h a $h b dvd y $h (a + 1) $h (b + 1)" 
      and a1: "Suc a < dim_row x" and a2: "Suc a < dim_col x" for a
  proof -
    have dim_row_CARD: "dim_row x = CARD('m)"
      using Mod_Type_Connect.dim_row_transfer_rule rel_xy by blast
    have dim_col_CARD: "dim_col x = CARD('n)"
      using Mod_Type_Connect.dim_col_transfer_rule rel_xy by blast
    let ?a' = "from_nat a::'m"
    let ?b' = "from_nat a::'n"
    have Suc_a_less_CARD: "a + 1 < CARD('m)" using a1 dim_row_CARD by auto
    have Suc_b_less_CARD: "a + 1 < CARD('n)" using a2
      by (metis Mod_Type_Connect.dim_col_transfer_rule Suc_eq_plus1 rel_xy)
    have aa'[transfer_rule]: "Mod_Type_Connect.HMA_I a ?a'"
      unfolding Mod_Type_Connect.HMA_I_def
      by (metis Suc_a_less_CARD add_lessD1 mod_type_class.to_nat_from_nat_id)
    have [transfer_rule]: "Mod_Type_Connect.HMA_I (a+1) (?a' + 1)" 
      unfolding Mod_Type_Connect.HMA_I_def
      unfolding from_nat_suc[symmetric] using to_nat_from_nat_id[OF Suc_a_less_CARD] by auto
    have ab'[transfer_rule]: "Mod_Type_Connect.HMA_I a ?b'"
      unfolding Mod_Type_Connect.HMA_I_def 
      by (metis Suc_b_less_CARD add_lessD1 mod_type_class.to_nat_from_nat_id)
    have [transfer_rule]: "Mod_Type_Connect.HMA_I (a+1) (?b' + 1)" 
      unfolding Mod_Type_Connect.HMA_I_def
      unfolding from_nat_suc[symmetric] using to_nat_from_nat_id[OF Suc_b_less_CARD] by auto      
    have aa'1: "a = to_nat ?a'" using aa' by (simp add: Mod_Type_Connect.HMA_I_def)
    have ab'1: "a = to_nat ?b'" using ab' by (simp add: Mod_Type_Connect.HMA_I_def)
    have "Suc (to_nat ?a') < nrows y" using a1 dim_row_CARD
      by (simp add: mod_type_class.to_nat_from_nat_id nrows_def)
    moreover have "Suc (to_nat ?b') < ncols y" using a2 dim_col_CARD
      by (simp add: mod_type_class.to_nat_from_nat_id ncols_def)
    ultimately have SNF': "y $h ?a' $h ?b' dvd y $h (?a' + 1) $h (?b' + 1)" 
      using SNF ab'1 aa'1 by auto    
     have "index_hma y ?a' ?b' = x $$ (a, a)" by (transfer, simp)
     moreover have "index_hma y (?a'+1) (?b'+1) = x $$ (a+1, a+1)" by (transfer, simp)
     ultimately show ?thesis using SNF' unfolding index_hma_def by auto
  qed
  ultimately show ?case unfolding Smith_normal_form_mat_def Smith_normal_form_def
    using rel_xy by (auto) (transfer', auto)+
qed



lemma HMA_admits_SNF [transfer_rule]: 
  "((Mod_Type_Connect.HMA_M :: _  'a :: comm_ring_1 ^ 'n::{mod_type} ^ 'n::{mod_type}  _) ===> (=)) 
  admits_SNF_JNF admits_SNF_HA"
proof (intro rel_funI, goal_cases)
  case (1 x y)
  note [transfer_rule] = this
  hence id: "dim_row x = CARD('n)" by (auto simp: Mod_Type_Connect.HMA_M_def)
  then show ?case unfolding admits_SNF_JNF_def admits_SNF_HA_def 
    by (transfer, auto, metis "1" Mod_Type_Connect.dim_col_transfer_rule)
qed  
end



(*If the following result holds, then I will get the result.
  
  But the theorem is false, since the assumption fixes the type 'n (within the proof is not 
  arbitrary any more). We cannot quantify over type variables in Isabelle/HOL.*)

(*
lemma diagonal_admits_SNF_imp_bezout_ring_JNF3:
  assumes admits_SNF: "∀A. (A::'a mat) ∈ carrier_mat (CARD('n)) (CARD('n)) ∧ isDiagonal_mat A 
⟶ (∃P Q. P ∈ carrier_mat (dim_row A) (dim_row A) 
  ∧ Q ∈ carrier_mat (dim_row A) (dim_row A) ∧ invertible_mat P ∧ invertible_mat Q 
  ∧ Smith_normal_form_mat (P*A*Q))"
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class)" 
  apply (rule diagonal_admits_SNF_imp_bezout_ring_JNF, auto)
*)


text‹Here we have a problem when trying to apply local type definitions›
(*
Once the assumption is translated to JNF, we get that it holds for all matrices with 
CARD('n) rows and CARD('n) columns. That is, we do not have the result for any matrix, just 
for matrices of such dimensions (within the proof, the type 'n is not arbitrary, is fixed).
*)
lemma diagonal_admits_SNF_imp_bezout_ring:
  assumes admits_SNF: "A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. isDiagonal A 
     (P Q. invertible (P::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}) 
         invertible (Q::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}) 
         Smith_normal_form (P**A**Q))"
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class)"
proof (rule diagonal_admits_SNF_imp_bezout_ring_JNF, auto)
  fix A::"'a mat" and n 
    assume A: "A  carrier_mat n n" and diag_A: "isDiagonal_mat A"           
  have a: "A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type}. admits_SNF_HA A" 
    using admits_SNF unfolding admits_SNF_HA_def .
  have JNF: "(A::'a mat) carrier_mat CARD('n) CARD('n). admits_SNF_JNF A" 
  (*We can get this result, but this does not imply that it holds for any n × n matrix, just 
    for the concrete case that n = CARD('n). Within this proof, we cannot apply local type 
    definitions, since the 'n is not an schematic variable any more, it is fixed.*)
  proof
    fix A::"'a mat" 
    assume A: "A  carrier_mat CARD('n) CARD('n)"
    let ?B = "(Mod_Type_Connect.to_hmam  A::'a::comm_ring_1^'n::{mod_type}^'n::{mod_type})"
    have [transfer_rule]: "Mod_Type_Connect.HMA_M A ?B"
      using A unfolding Mod_Type_Connect.HMA_M_def by auto
    have b: "admits_SNF_HA ?B" using a by auto
    show "admits_SNF_JNF A" using b by transfer
  qed 
  (*Here we cannot apply local type definitions (either cancel_card_constraint or 
  cancel_type_definition) to thm JNF*)
  thus "P. P  carrier_mat n n 
             (Q. Q  carrier_mat n n  invertible_mat P 
         invertible_mat Q  Smith_normal_form_mat (P * A * Q))"
    using JNF A diag_A unfolding admits_SNF_JNF_def unfolding square_mat.simps oops


text‹This means that the @{text "⟹"}  implication cannot be proven in HA, since we cannot quantify
over type variables in Isabelle/HOL. We then prove both implications in JNF.›


subsection ‹Transfering the @{text "⟸"} implication from HA to JNF using transfer rules 
  and local type definitions›

(*
  I need to transfer the theorem bezout_ring_imp_diagonal_admits_SNF (stated in HA) to JNF.
  The first necessary step is to prove transfer rules to connect matrices in HA (when the type
  of the indexes must be mod_type). The original connection HMA_Connect presented in the 
  Perron--Frobenius development just connects matrices of type 'a^'b::finite^'c::finite with 
  the corresponding ones in JNF, but I need to transfer theorems with matrices of type:
  'a^'b::mod_type^'c::mod_type.

  The file that allows this bridge is Mod_Type_Connect.  

  Once that step is carried out, I would have to transfer the result by means of the lifting
  and transfer package and then apply local type definitions to get rid of the type (that is,
  to change CARD('n) by an arbitrary n).

  The usual approach consists of applying lifting and transfer to the theorem, and then we
  obtain a fact like 
        
          A ∈ carrier_mat (CARD('n::mod_type)) (CARD('n::mod_type))

  When trying to apply local type definitions (to substitute CARD('n::mod_type) by n), then
  I would have to apply interalize_sort and then proving the restriction class.mod_type (together
  with the operations associated to that class). Since the mod_type class already introduced
  several type restrictions (times, neg_numeral_well_order), operations (+,-) and constants (1,0),
  this means that we have to proceed using dictionary construction. We would have to define
  a mod_type with explicit operations, to get 'a only of type 'a::type.
  
  definition "mod_type_with n (tms::'a⇒'a⇒'a) mns pls zr umns (one'::'a)  
        (less_eq'::'a⇒'a⇒bool) (less'::'a⇒'a⇒bool) (Rep_op::'a⇒int) (Abs_op::int⇒'a)
      ≡ (type_definition Rep_op Abs_op {0..<n} ∧  1 < n
      ∧ (zr = Abs_op 0)
      ∧ (one' = Abs_op 1)
      ∧ (∀x y. pls x y = Abs_op (((Rep_op x) + (Rep_op y)) mod (n)))
      ∧ (∀x y. tms x y = Abs_op (((Rep_op x) * (Rep_op y)) mod (n)))
      ∧ (∀x y. mns x y = Abs_op (((Rep_op x) - (Rep_op y)) mod (n)))
      ∧ (∀x. umns x = Abs_op ((- (Rep_op x)) mod (n)))
      ∧ (∀x y. less' x y ⟶ (Rep_op x) < (Rep_op y))
      ∧ class.neg_numeral mns pls zr umns
      ∧ class.wellorder less_eq' less')"

  Once this is completed, I would have to connect mod_type and mod_type_with, 
  prove new transfer rules and so on. This is the usual approach and has been successfully applied,
  for instance, by Fabian Immler to transform a (type based) library of linear algebra into another
  one with explicit carriers.

  Fortunately, in this case there is a shortcut: we can use the type 'a mod_ring from the
  Berlekamp--Zassenhaus development to express the lemma in HA 
  (thm bezout_ring_imp_diagonal_admits_SNF) using that type (the type 'a mod_ring is an instance
  of the mod_type class, and then is a particular case).

  This means that any lemma that has a matrix of type 'a^'b::mod_type^'c^'mod_type can be expressed
  as 'a^'b mod_ring^'c mod_ring, where 'b and 'c must satisfy the nontriv restriction 
  (they must have more than one element).

  This is done in the file Finite_Field_Mod_Type_Connection, which shows that 'a mod_ring is an
  instance of the mod_type class.

  This type 'a mod_ring has a very useful property: CARD('b mod_ring) = CARD('b)
  This means that it is very easy to apply local type definitions. The problematic fact
  would then be transformed to:
  
      A ∈ carrier_mat (CARD('n::nontriv)) (CARD('n::nontriv)). 

  It is very easy to apply local type definitions to this fact, since it is very easy to get rid
  of the nontriv restriction (on the contrary, the mod_type restriction was quite hard).

*)


(*
  In our concrete case: we write the theorem in terms of the mod_ring type thanks to 
  the file Finite_Field_Mod_Type_Connection.

  With this type 'n::nontriv mod_ring I can easily apply local type definitions, since we
  will get CARD(?'n::nontriv).
*)

lemma bezout_ring_imp_diagonal_admits_SNF_mod_ring:
  assumes of: "OFCLASS('a::comm_ring_1, bezout_ring_class)"
  shows "A::'a^'n::nontriv mod_ring^'n::nontriv mod_ring. isDiagonal A 
     (P Q. 
        invertible (P::'a^'n::nontriv mod_ring^'n::nontriv mod_ring)  
        invertible (Q::'a^'n::nontriv mod_ring^'n::nontriv mod_ring)  
        Smith_normal_form (P**A**Q))" 
  using bezout_ring_imp_diagonal_admits_SNF[OF assms] by auto

lemma bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits: 
  assumes of: "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus" (*It is equivalent to the statement based on OFCLASS*)
  shows "A::'a^'n::nontriv mod_ring^'n::nontriv mod_ring. admits_SNF_HA A"
  using bezout_ring_imp_diagonal_admits_SNF
        [OF Rings2.class.Rings2.bezout_ring.of_class.intro[OF of]] 
  unfolding admits_SNF_HA_def by auto

text‹I start here to apply local type definitions›

context
  fixes p::nat
  assumes local_typedef: "(Rep :: ('b  int)) Abs. type_definition Rep Abs {0..<p :: int}"
  and p: "p>1"
begin

lemma type_to_set:
  shows "class.nontriv TYPE('b)" (is ?a) and "p=CARD('b)" (is ?b)
proof -
  from local_typedef obtain Rep::"('b  int)" and Abs 
    where t: "type_definition Rep Abs {0..<p :: int}" by auto
  have "card (UNIV :: 'b set) = card {0..<p}" using t type_definition.card by fastforce
  also have "... = p" by auto
  finally show ?b ..
  then show ?a unfolding class.nontriv_def using p by auto
qed


text‹I transfer the lemma from HA to JNF, substituting @{text "CARD('n)"} by $p$. 
  I apply @{text "internalize-sort"} to @{text "'n"} and get rid of 
  the @{text "nontriv"} restriction.›

lemma bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits_aux:
  assumes "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus"
  shows "Ball {A::'a::comm_ring_1 mat. A  carrier_mat p p} admits_SNF_JNF"
  using bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits[untransferred, unfolded CARD_mod_ring, 
      internalize_sort "'n::nontriv", where ?'a='b]
  unfolding type_to_set(2)[symmetric] using type_to_set(1) assms by auto
end

text‹The @{text "⟸"} implication in JNF›

text‹Since @{text "nontriv"} imposes the type to have more than one element, 
  the cases $n=0$ (@{text "A ∈ carrier_mat 0 0"}) and $n = 1$ (@{text "A ∈ carrier_mat 1 1"})
  must be treated separately.›

lemma bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits_aux2:
  assumes of: "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus"
  shows "(A::'a mat)carrier_mat n n. admits_SNF_JNF A"
proof (cases "n = 0")
  case True  
  show ?thesis
    by (rule, unfold True admits_SNF_JNF_def isDiagonal_mat_def invertible_mat_def 
        Smith_normal_form_mat_def carrier_mat_def inverts_mat_def, fastforce)
next
  case False note not0 = False
  show ?thesis
  proof (cases "n=1") 
  case True
  show ?thesis 
    by (rule, unfold True admits_SNF_JNF_def isDiagonal_mat_def invertible_mat_def 
        Smith_normal_form_mat_def carrier_mat_def inverts_mat_def, auto)
       (metis dvd_1_left index_one_mat(2) index_one_mat(3) less_Suc0 nat_dvd_not_less 
        right_mult_one_mat' zero_less_Suc)
  next
    case False
    then have "n>1" using not0 by auto
    then show ?thesis (*Here I apply the local type definition rule, to cancel the type*)
      using bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits_aux[cancel_type_definition, of n] of 
      by auto
  qed
qed
    
text ‹Alternative statements›
  
lemma bezout_ring_imp_diagonal_admits_SNF_JNF:
  assumes of: "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus"
  shows "A::'a mat. admits_SNF_JNF A"
proof 
  fix A::"'a mat"
  have "A carrier_mat (dim_row A) (dim_col A)" unfolding carrier_mat_def by auto
  thus "admits_SNF_JNF A" 
    using bezout_ring_imp_diagonal_admits_SNF_mod_ring_admits_aux2[OF of]
    by (metis admits_SNF_JNF_def square_mat.elims(2))
qed


lemma admits_SNF_JNF_alt_def:
  "(A::'a::comm_ring_1 mat. admits_SNF_JNF A) 
  = (A n. (A::'a mat)  carrier_mat n n  isDiagonal_mat A
   (P Q. P  carrier_mat n n  Q  carrier_mat n n  invertible_mat P  invertible_mat Q 
       Smith_normal_form_mat (P*A*Q)))" (is "?a = ?b")
  by (auto simp add: admits_SNF_JNF_def, metis carrier_matD(1) carrier_matD(2), blast)


subsection ‹Final theorem in JNF›
text ‹Final theorem using @{text "class.bezout_ring"}

theorem diagonal_admits_SNF_iff_bezout_ring:
  shows "class.bezout_ring (*) (1::'a::comm_ring_1) (+) 0 (-) uminus 
   (A::'a mat. admits_SNF_JNF A)" (is "?a  ?b")
proof 
  assume ?a
  thus ?b using bezout_ring_imp_diagonal_admits_SNF_JNF by auto
next
  assume b: ?b
  have rw: "A n. (A::'a mat)  carrier_mat n n  isDiagonal_mat A 
          (P Q. P  carrier_mat n n  Q  carrier_mat n n  invertible_mat P 
           invertible_mat Q  Smith_normal_form_mat (P * A * Q))"
    using admits_SNF_JNF_alt_def b by auto  
  show ?a
    using diagonal_admits_SNF_imp_bezout_ring_JNF[OF rw] 
    using OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a='a]
    by auto
qed

text ‹Final theorem using @{text "OFCLASS"}

theorem diagonal_admits_SNF_iff_bezout_ring':
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class)  (A::'a mat. admits_SNF_JNF A)"
proof 
  fix A::"'a mat"
  assume a: "OFCLASS('a, bezout_ring_class)"  
  show "admits_SNF_JNF A"
    using OFCLASS_bezout_ring_imp_class_bezout_ring[OF a] diagonal_admits_SNF_iff_bezout_ring
    by auto
next
  assume "(A::'a mat. admits_SNF_JNF A)"  
  hence *: "class.bezout_ring (*) (1::'a) (+) 0 (-) uminus" 
    using diagonal_admits_SNF_iff_bezout_ring by auto
  show "OFCLASS('a, bezout_ring_class)"
    by (rule Rings2.class.Rings2.bezout_ring.of_class.intro, rule *)
qed

end

Theory SNF_Uniqueness

(*
    Author:      Jose Divasón
    Email:       jose.divason@unirioja.es
*)

section ‹Uniqueness of the Smith normal form›

theory SNF_Uniqueness
imports
  Cauchy_Binet
  Smith_Normal_Form_JNF
  Admits_SNF_From_Diagonal_Iff_Bezout_Ring
begin

lemma dvd_associated1:
  fixes a::"'a::comm_ring_1"
  assumes "u. u dvd 1  a = u*b"
  shows "a dvd b  b dvd a"
  using assms by auto


text ‹This is a key lemma. It demands the type class to be an integral domain. This means that
the uniqueness result will be obtained for GCD domains, instead of rings.›
lemma dvd_associated2:
  fixes a::"'a::idom"
  assumes ab: "a dvd b" and ba: "b dvd a" and a: "a0"
  shows "u. u dvd 1  a = u*b"
proof -
  obtain k where a_kb: "a = k*b" using ab unfolding dvd_def
    by (metis Groups.mult_ac(2) ba dvdE)
  obtain q where b_qa: "b = q*a" using ba unfolding dvd_def
    by (metis Groups.mult_ac(2) ab dvdE)
  have 1: "a = k*q*a" using a_kb b_qa by auto
  hence "k*q = 1" using a by simp
  thus ?thesis using 1 by (metis a_kb dvd_triv_left)
qed

corollary dvd_associated:
  fixes a::"'a::idom"
  assumes "a0"
  shows "(a dvd b  b dvd a) = (u. u dvd 1  a = u*b)"
  using assms dvd_associated1 dvd_associated2 by metis


lemma exists_inj_ge_index:
  assumes S: "S  {0..<n}" and Sk: "card S = k"
  shows "f. inj_on f {0..<k}  f`{0..<k} = S  (i{0..<k}. i  f i)"
proof -
  have "h. bij_betw h {0..<k} S"
    using S Sk ex_bij_betw_nat_finite subset_eq_atLeast0_lessThan_finite by blast
  from this obtain g where inj_on_g: "inj_on g {0..<k}" and gk_S: "g`{0..<k} = S"
    unfolding bij_betw_def by blast
  let ?f = "strict_from_inj k g"
  have "strict_mono_on ?f {0..<k}" by (rule strict_strict_from_inj[OF inj_on_g])
  hence 1: "inj_on ?f {0..<k}" using strict_mono_on_imp_inj_on by blast
  have 2: "?f`{0..<k} = S" by (simp add: strict_from_inj_image' inj_on_g gk_S)
  have 3: "i{0..<k}. i  ?f i"
  proof
    fix i assume i: "i  {0..<k}"
    let ?xs = "sorted_list_of_set (g`{0..<k})"
    have "strict_from_inj k g i = ?xs ! i" unfolding strict_from_inj_def using i by auto
    moreover have "i  ?xs ! i"
    proof (rule sorted_wrt_less_idx, rule sorted_distinct_imp_sorted_wrt)
      show "sorted ?xs"
        using sorted_sorted_list_of_set by blast
      show "distinct ?xs" using distinct_sorted_list_of_set by blast
      show "i < length ?xs"
        by (metis S Sk atLeast0LessThan distinct_card distinct_sorted_list_of_set gk_S i
            lessThan_iff set_sorted_list_of_set subset_eq_atLeast0_lessThan_finite)
    qed
    ultimately show "i  ?f i" by auto
  qed
  show ?thesis using 1 2 3 by auto
qed


subsection ‹More specific results about submatrices›


lemma diagonal_imp_submatrix0:
  assumes dA: "diagonal_mat A" and A_carrier: "A carrier_mat n m"
  and Ik: "card I = k" and Jk: "card J = k"
  and r: "row_index  I. row_index < n" (*I ⊆ {0..<n}*)
  and c: "col_index  J. col_index < m"
  and a: "a<k" and b: "b<k"
shows "submatrix A I J $$ (a, b) = 0  submatrix A I J $$ (a,b) = A $$(pick I a, pick I a)"
proof (cases "submatrix A I J $$ (a, b) = 0")
  case True
  then show ?thesis by auto
next
  case False note not0 = False
  have aux: "submatrix A I J $$ (a, b) = A $$(pick I a, pick J b)"
  proof (rule submatrix_index)
    have "card {i. i < dim_row A  i  I} = k"
      by (smt A_carrier Ik carrier_matD(1) equalityI mem_Collect_eq r subsetI)
    moreover have "card {i. i < dim_col A  i  J} = k"
      by (metis (no_types, lifting) A_carrier Jk c carrier_matD(2) carrier_mat_def
         equalityI mem_Collect_eq subsetI)
    ultimately show " a < card {i. i < dim_row A  i  I}"
      and "b < card {i. i < dim_col A  i  J}" using a b by auto
  qed
  thus ?thesis
  proof (cases "pick I a = pick J b")
    case True
    then show ?thesis using aux by auto
  next
    case False
    then show ?thesis
      by (metis aux A_carrier Ik Jk a b c carrier_matD dA diagonal_mat_def pick_in_set_le r)
  qed
qed



lemma diagonal_imp_submatrix_element_not0:
  assumes dA: "diagonal_mat A"
  and A_carrier: "A  carrier_mat n m"
  and Ik: "card I = k" and Jk: "card J = k"
  and I: "I  {0..<n}"
  and J: "J  {0..<m}"
  and b: "b < k"
  and ex_not0: "i. i<k  submatrix A I J $$ (i, b)  0"
shows "∃!i. i<k  submatrix A I J $$ (i, b)  0"
proof -
  have I_eq: "I = {i. i < dim_row A  i  I}" using I A_carrier unfolding carrier_mat_def by auto
  have J_eq: "J = {i. i < dim_col A  i  J}" using J A_carrier unfolding carrier_mat_def by auto
  obtain a where sub_ab: "submatrix A I J $$ (a, b)  0" and ak: "a < k" using ex_not0 by auto
  moreover have "i = a" if sub_ib: "submatrix A I J $$ (i, b)  0" and ik: "i < k" for i
  proof -
    have 1: "pick I i < dim_row A"
      using I_eq Ik ik pick_in_set_le by auto
    have 2: "pick J b < dim_col A"
      using J_eq Jk b pick_le by auto
    have 3: "pick I a < dim_row A"
      using I_eq Ik calculation(2) pick_le by auto
    have "submatrix A I J $$ (i, b) = A $$ (pick I i, pick J b)"
      by (rule submatrix_index, insert I_eq Ik ik J_eq Jk b, auto)
    hence pick_Ii_Jb: "pick I i = pick J b" using dA sub_ib 1 2 unfolding diagonal_mat_def by auto
    have "submatrix A I J $$ (a, b) = A $$ (pick I a, pick J b)"
      by (rule submatrix_index, insert I_eq Ik ak J_eq Jk b, auto)
    hence pick_Ia_Jb: "pick I a = pick J b" using dA sub_ab 3 2 unfolding diagonal_mat_def by auto
    have pick_Ia_Ii: "pick I a = pick I i" using pick_Ii_Jb pick_Ia_Jb by simp
    thus ?thesis by (metis Ik ak ik nat_neq_iff pick_mono_le)
  qed
  ultimately show ?thesis by auto
qed


lemma submatrix_index_exists:
  assumes A_carrier: "A carrier_mat n m"
  and Ik: "card I = k" and Jk: "card J = k"
  and a: "a  I" and b: "b  J" and k: "k > 0"
  and I: "I  {0..<n}" and J: "J  {0..<m}"
shows "a' b'. a' < k  b' < k  submatrix A I J $$ (a',b') = A $$ (a,b)
         a = pick I a'  b = pick J b'"
proof -
  let ?xs = "sorted_list_of_set I"
  let ?ys = "sorted_list_of_set J"
  have finI: "finite I" and finJ: "finite J" using k Ik Jk card_ge_0_finite by metis+
  have set_xs: "set ?xs = I" by (rule set_sorted_list_of_set[OF finI])
  have set_ys: "set ?ys = J" by (rule set_sorted_list_of_set[OF finJ])
  have a_in_xs: "a  set ?xs" and b_in_ys: "b  set ?ys" using set_xs a set_ys b by auto
  have length_xs: "length ?xs = k" by (metis Ik distinct_card set_xs sorted_list_of_set(3))
  have length_ys: "length ?ys = k" by (metis Jk distinct_card set_ys sorted_list_of_set(3))
  obtain a' where a': "?xs ! a' = a" and a'_length: "a' < length ?xs"
    by (meson a_in_xs in_set_conv_nth)
  obtain b' where b': "?ys ! b' = b" and b'_length: "b' < length ?ys"
    by (meson b_in_ys in_set_conv_nth)
  have pick_a: "a = pick I a'" using a' a'_length finI sorted_list_of_set_eq_pick by auto
  have pick_b: "b = pick J b'" using b' b'_length finJ sorted_list_of_set_eq_pick by auto
  have I_rw: "I = {i. i < dim_row A  i  I}" and J_rw: "J = {i. i < dim_col A  i  J}"
    using I A_carrier J by auto
  have a'k: "a' < k" using a'_length length_xs by auto
  moreover have b'k: "b'<k" using b'_length length_ys by auto
  moreover have sub_eq: "submatrix A I J $$ (a', b') = A $$ (a, b)"
    unfolding pick_a pick_b
    by (rule submatrix_index, insert J_rw I_rw Ik Jk a'_length length_xs b'_length length_ys, auto)
  ultimately show ?thesis using pick_a pick_b by auto
qed


lemma mat_delete_submatrix_insert:
  assumes A_carrier: "A  carrier_mat n m"
  and Ik: "card I = k" and Jk: "card J = k"
  and I: "I  {0..<n}" and J: "J  {0..<m}"
  and a: "a < n" and b: "b < m"
  and k: "k < min n m"
  and a_notin_I: "a  I" and b_notin_J: "b  J"
  and a'k: "a' < Suc k" and b'k:  "b' < Suc k"
  and a_def: "pick (insert a I) a' = a"
  and b_def: "pick (insert b J) b' = b"
shows "mat_delete (submatrix A (insert a I) (insert b J)) a' b' = submatrix A I J" (is "?lhs = ?rhs")
proof (rule eq_matI)
  have I_eq: "I = {i. i < dim_row A  i  I}"
    using I A_carrier unfolding carrier_mat_def by auto
  have J_eq: "J = {i. i < dim_col A  i  J}"
    using J A_carrier unfolding carrier_mat_def by auto
  have insert_I_eq: "insert a I = {i. i < dim_row A  i  insert a I}"
    using I A_carrier a k unfolding carrier_mat_def by auto
  have card_Suc_k: "card {i. i < dim_row A  i  insert a I} = Suc k"
    using insert_I_eq Ik a_notin_I
    by (metis I card_insert_disjoint finite_atLeastLessThan finite_subset)
  have insert_J_eq: "insert b J = {i. i < dim_col A  i  insert b J}"
    using J A_carrier b k unfolding carrier_mat_def by auto
  have card_Suc_k': "card {i. i < dim_col A  i  insert b J} = Suc k"
    using insert_J_eq Jk b_notin_J
    by (metis J card_insert_disjoint finite_atLeastLessThan finite_subset)
  show "dim_row ?lhs = dim_row ?rhs"
    unfolding mat_delete_dim unfolding dim_submatrix using card_Suc_k I_eq Ik by auto
  show "dim_col ?lhs = dim_col ?rhs"
    unfolding mat_delete_dim unfolding dim_submatrix using card_Suc_k' J_eq Jk by auto
  fix i j assume i: "i < dim_row (submatrix A I J)"
    and j: "j < dim_col (submatrix A I J)"
  have ik: "i < k" by (metis I_eq Ik dim_submatrix(1) i)
  have jk: "j < k" by (metis J_eq Jk dim_submatrix(2) j)
  show "?lhs $$ (i, j) = ?rhs $$ (i, j)"
  proof -
    have index_eq1: "pick (insert a I) (insert_index a' i) = pick I i"
      by (rule pick_insert_index[OF Ik a_notin_I ik a_def], simp add: Ik a'k)
    have index_eq2: "pick (insert b J) (insert_index b' j) = pick J j"
      by (rule pick_insert_index[OF Jk b_notin_J jk b_def], simp add: Jk b'k)
    have "?lhs $$ (i,j)
        = (submatrix A (insert a I) (insert b J)) $$ (insert_index a' i, insert_index b' j)"
    proof (rule mat_delete_index[symmetric, OF _ a'k b'k ik jk])
      show "submatrix A (insert a I) (insert b J)  carrier_mat (Suc k) (Suc k)"
        by (metis card_Suc_k card_Suc_k' carrier_matI dim_submatrix(1) dim_submatrix(2))
    qed
    also have "... = A $$ (pick (insert a I) (insert_index a' i), pick (insert b J) (insert_index b' j))"
    proof (rule submatrix_index)
      show "insert_index a' i < card {i. i < dim_row A  i  insert a I}"
        using card_Suc_k ik insert_index_def by auto
      show "insert_index b' j < card {j. j < dim_col A  j  insert b J}"
        using card_Suc_k' insert_index_def jk by auto
    qed
    also have "... = A $$ (pick I i, pick J j)" unfolding index_eq1 index_eq2 by auto
    also have "... = submatrix A I J $$ (i,j)"
      by (rule submatrix_index[symmetric], insert ik I_eq Ik Jk J_eq jk, auto)
    finally show ?thesis .
  qed
qed



subsection ‹On the minors of a diagonal matrix›

lemma det_minors_diagonal:
  assumes dA: "diagonal_mat A" and A_carrier: "A  carrier_mat n m"
    and Ik: "card I = k" and Jk: "card J = k"
    and r: "I  {0..<n}"
    and c: "J  {0..<m}" and k: "k>0"
  shows "det (submatrix A I J) = 0
   (xs. (det (submatrix A I J) = prod_list xs  det (submatrix A I J) = - prod_list xs)
   set xs  {A$$(i,i)|i. i<min n m  A$$(i,i) 0}  length xs = k)"
  using Ik Jk r c k
proof (induct k arbitrary: I J)
  case 0
  then show ?case by auto
next
  case (Suc k)
  note cardI = Suc.prems(1)
  note cardJ = Suc.prems(2)
  note I = Suc.prems(3)
  note J = Suc.prems(4)
  have *: "{i. i < dim_row A  i  I} = I" using I Ik A_carrier carrier_mat_def by auto
  have **: "{j. j < dim_col A  j  J} = J" using J Jk A_carrier carrier_mat_def by auto
  show ?case
  proof (cases "k = 0")
    case True note k0 = True
    from this obtain a where aI: "I = {a}" using True cardI card_1_singletonE by auto
    from this obtain b where bJ: "J = {b}" using True cardJ card_1_singletonE by auto
    have an: "a<n" using aI I by auto
    have bm: "b<m" using bJ J by auto
    have sub_carrier: "submatrix A {a} {b}  carrier_mat 1 1"
      unfolding carrier_mat_def submatrix_def
      using * ** aI bJ by auto
    have 1: "det (submatrix A {a} {b}) = (submatrix A {a} {b}) $$ (0,0)"
      by (rule det_singleton[OF sub_carrier])
    have 2: "... = A $$ (a,b)"
      by (rule submatrix_singleton_index[OF A_carrier an bm])
    show ?thesis
    proof (cases "A $$ (a,b)  0")
      let ?xs = "[submatrix A {a} {b} $$ (0,0)]"
      case True
      hence "a = b" using dA A_carrier an bm unfolding diagonal_mat_def carrier_mat_def by auto
      hence "set ?xs  {A $$ (i, i) |i. i < min n m  A $$ (i, i)  0}"
        using 2 True an bm by auto
      moreover have "det (submatrix A {a} {b}) = prod_list ?xs" using 1 by auto
      moreover have "length ?xs = Suc k" using k0 by auto
      ultimately show ?thesis using an bm unfolding aI bJ by blast
    next
      case False
      then show ?thesis using 1 2 aI bJ by auto
    qed
  next
    case False
    hence k0: "0 < k" by simp
    have k: "k < min n m"
      by (metis I J cardI cardJ le_imp_less_Suc less_Suc_eq_le min.commute
          min_def not_less subset_eq_atLeast0_lessThan_card)
    have subIJ_carrier: "(submatrix A I J)  carrier_mat (Suc k) (Suc k)"
      unfolding carrier_mat_def using * ** cardI cardJ
      unfolding submatrix_def by auto
    obtain b' where b'k: "b' < Suc k" by auto
    let ?f="λi. submatrix A I J $$ (i, b') * cofactor (submatrix A I J) i b'"
    have det_rw: "det (submatrix A I J)
        = (i<Suc k. submatrix A I J $$ (i, b') * cofactor (submatrix A I J) i b')"
      by (rule laplace_expansion_column[OF subIJ_carrier b'k])
    show ?thesis
    proof (cases "a'<Suc k. submatrix A I J $$ (a',b')  0")
      case True
      obtain a' where sub_IJ_0: "submatrix A I J $$ (a',b')  0"
        and a'k: "a' < Suc k"
        and unique: "j. j<Suc k  submatrix A I J $$ (j,b')  0  j = a'"
        using diagonal_imp_submatrix_element_not0[OF dA A_carrier cardI cardJ I J b'k True] by auto
      have "submatrix A I J $$ (a', b') = A $$ (pick I a', pick J b')"
        by (rule submatrix_index, auto simp add: "*" a'k cardI "**" b'k cardJ)
      from this obtain a b where an: "a < n" and bm:  "b < m"
        and sub_index: "submatrix A I J $$ (a', b') = A $$ (a, b)"
        and pick_a: "pick I a' = a" and pick_b: "pick J b' = b"
        using * ** A_carrier a'k b'k cardI cardJ pick_le by fastforce
      obtain I' where aI': "I = insert a I'" and a_notin: "a  I'"
        by (metis Set.set_insert a'k cardI pick_a pick_in_set_le)
      obtain J' where bJ': "J = insert b J'" and b_notin: "b  J'"
        by (metis Set.set_insert b'k cardJ pick_b pick_in_set_le)
      have Suc_k0: "0 < Suc k" by simp
      have aI: "a  I" using aI' by auto
      have bJ: "b  J" using bJ' by auto
      have cardI':  "card I' = k"
        by (metis aI' a_notin cardI card.infinite card_insert_disjoint
            finite_insert nat.inject nat.simps(3))
      have cardJ':  "card J' = k"
        by (metis bJ' b_notin cardJ card.infinite card_insert_disjoint
            finite_insert nat.inject nat.simps(3))
      have I': "I'  {0..<n}" using I aI' by blast
      have J': "J'  {0..<m}" using J bJ' by blast
      have det_sub_I'J': "Determinant.det (submatrix A I' J') = 0 
      (xs. (det (submatrix A I' J') = prod_list xs  det (submatrix A I' J') = - prod_list xs)
       set xs  {A $$ (i, i) |i. i < min n m  A $$ (i, i)  0}  length xs = k)"
      proof (rule Suc.hyps[OF cardI' cardJ' _ _ k0])
        show "I'  {0..<n}" using I aI' by blast
        show "J'  {0..<m}" using J bJ' by blast
      qed
      have mat_delete_sub:
        "mat_delete (submatrix A (insert a I') (insert b J')) a' b' = submatrix A I' J'"
        by (rule mat_delete_submatrix_insert[OF A_carrier cardI' cardJ' I' J' an bm k
              a_notin b_notin a'k b'k],insert pick_a pick_b aI' bJ', auto)
      have set_rw: "{0..<Suc k} = insert a' ({0..<Suc k}-{a'})"
        by (simp add: a'k insert_absorb)
      have rw0: "sum ?f ({0..<Suc k}-{a'}) = 0" by (rule sum.neutral, insert unique, auto)
      have "det (submatrix A I J)
        = (i<Suc k. submatrix A I J $$ (i, b') * cofactor (submatrix A I J) i b')"
        by (rule laplace_expansion_column[OF subIJ_carrier b'k])
      also have "... = ?f a' + sum ?f ({0..<Suc k}-{a'})"
        by (metis (no_types, lifting) Diff_iff atLeast0LessThan finite_atLeastLessThan
            finite_insert set_rw singletonI sum.insert)
      also have "... = ?f a'" using rw0 unfolding cofactor_def by auto
      also have "... = submatrix A I J $$ (a', b') * ((-1) ^ (a' + b') * det (submatrix A I' J'))"
        unfolding cofactor_def using mat_delete_sub aI' bJ' by simp
      finally have det_submatrix_IJ: "det (submatrix A I J)
         = A $$ (a, b) * ((- 1) ^ (a' + b') * det (submatrix A I' J'))" unfolding sub_index .
      show ?thesis
      proof (cases "det (submatrix A I' J') = 0")
        case True
        then show ?thesis using det_submatrix_IJ by auto
      next
        case False note det_not0 = False
        from this obtain xs where prod_list_xs: "det (submatrix A I' J') = prod_list xs
           det (submatrix A I' J') = - prod_list xs"
          and xs: "set xs  {A $$ (i, i) |i. i < min n m  A $$ (i, i)  0}"
          and length_xs: "length xs = k"
          using det_sub_I'J' by blast
        let ?ys = "A$$(a,b) # xs"
        have length_ys: "length ?ys = Suc k" using length_xs by auto
        have a_eq_b: "a=b"
          using A_carrier an bm sub_IJ_0 sub_index dA unfolding diagonal_mat_def by auto
        have A_aa_in: "A$$(a,a)  {A $$ (i, i) |i. i < min n m  A $$ (i, i)  0}"
          using a_eq_b an bm sub_IJ_0 sub_index by auto
        have ys: "set ?ys  {A $$ (i, i) |i. i < min n m  A $$ (i, i)  0}"
          using xs A_aa_in a_eq_b by auto
        show ?thesis
        proof (cases "even (a'+b')")
          case True
          have det_submatrix_IJ: "det (submatrix A I J) = A $$ (a, b) * det (submatrix A I' J')"
            using det_submatrix_IJ True by auto
          show ?thesis
          proof (cases "det (submatrix A I' J') = prod_list xs")
            case True
            have "det (submatrix A I J) = prod_list ?ys"
              using det_submatrix_IJ unfolding True by auto
            then show ?thesis using ys length_ys by blast
          next
            case False
            hence "det (submatrix A I' J') = - prod_list xs" using prod_list_xs by simp
            hence "det (submatrix A I J) = - prod_list ?ys" using det_submatrix_IJ by auto
            then show ?thesis using ys length_ys by blast
          qed
        next
          case False
          have det_submatrix_IJ: "det (submatrix A I J) = A $$ (a, b) * - det (submatrix A I' J')"
            using det_submatrix_IJ False by auto
          show ?thesis
          proof (cases "det (submatrix A I' J') = prod_list xs")
            case True
            have "det (submatrix A I J) = - prod_list ?ys"
              using det_submatrix_IJ unfolding True by auto
            then show ?thesis using ys length_ys by blast
          next
            case False
            hence "det (submatrix A I' J') = - prod_list xs" using prod_list_xs by simp
            hence "det (submatrix A I J) = prod_list ?ys" using det_submatrix_IJ by auto
            then show ?thesis using ys length_ys by blast
          qed
        qed
      qed
    next
      case False
      have "sum ?f {0..<Suc k} = 0" by (rule sum.neutral, insert False, auto)
      thus ?thesis using det_rw
        by (simp add: atLeast0LessThan)
    qed
  qed
qed


definition "minors A k = {det (submatrix A I J)| I J. I  {0..<dim_row A}
   J  {0..<dim_col A}  card I = k  card J = k}"


lemma Gcd_minors_dvd:
  fixes A::"'a::{semiring_Gcd,comm_ring_1} mat"
  assumes PAQ_B: "P * A * Q = B"
  and P: "P  carrier_mat m m"
  and A: "A  carrier_mat m n"
  and Q: "Q  carrier_mat n n"
  and I: "I  {0..<dim_row A}" and J: "J  {0..<dim_col A}"
  and Ik: "card I = k" and Jk: "card J = k"
  shows "Gcd (minors A k) dvd det (submatrix B I J)"
proof -
  let ?subPA = "submatrix (P * A) I UNIV"
  let ?subQ = "submatrix Q UNIV J"
  have subPA: "?subPA  carrier_mat k n"
  proof -
    have "I = {i. i < dim_row P  i  I}" using P I A by auto
    hence "card {i. i < dim_row P  i  I} = k" using Ik by auto
    thus ?thesis using A unfolding submatrix_def by auto
  qed
  have subQ: "submatrix Q UNIV J  carrier_mat n k"
  proof -
    have J_eq: "J = {j. j < dim_col Q  j  J}" using Q J A by auto
    hence "card {j. j < dim_col Q  j  J} = k" using Jk by auto
    moreover have "card {i. i < dim_row Q  i  UNIV} = n" using Q by auto
    ultimately show ?thesis unfolding submatrix_def by auto
  qed
  have sub_sub_PA: "(submatrix ?subPA UNIV I') = submatrix (P * A) I I'" for I'
    using submatrix_split2[symmetric] by auto
  have det_subPA_rw: "det (submatrix (P * A) I I') =
    (J' | J'  {0..<m}  card J' = k. det ((submatrix P I J')) * det (submatrix A J' I'))"
    if I'1: "I'  {0..<n}" and I'2: "card I' = k" for I'
  proof -
    have "submatrix (P * A) I I' = submatrix P I UNIV * submatrix A UNIV I'"
      unfolding submatrix_mult ..
    also have "det ... = (C | C  {0..<m}  card C = k.
     det (submatrix (submatrix P I UNIV) UNIV C) * det (submatrix (submatrix A UNIV I') C UNIV))"
    proof (rule Cauchy_Binet)
      have "I = {i. i < dim_row P  i  I}" using P I A by auto
      thus "submatrix P I UNIV  carrier_mat k m" using Ik P unfolding submatrix_def by auto
      have "I' = {j. j < dim_col A  j  I'}" using I'1 A by auto
      thus "submatrix A UNIV I'  carrier_mat m k" using I'2 A unfolding submatrix_def by auto
    qed
    also have "... =  (J' | J'  {0..<m}  card J' = k.
      det (submatrix P I J') * det (submatrix A J' I'))"
      unfolding submatrix_split2[symmetric] submatrix_split[symmetric] by simp
    finally show ?thesis .
  qed
  have "det (submatrix B I J) = det (submatrix (P*A*Q) I J)" using PAQ_B by simp
  also have "... = det (?subPA * ?subQ)" unfolding submatrix_mult by auto
  also have "... = (I' | I'  {0..<n}  card I' = k. det (submatrix ?subPA UNIV I')
    * det (submatrix ?subQ I' UNIV))"
    by (rule Cauchy_Binet[OF subPA subQ])
  also have "... = (I' | I'  {0..<n}  card I' = k.
    det (submatrix (P * A) I I') * det (submatrix Q I' J))"
    using submatrix_split[symmetric, of Q] submatrix_split2[symmetric, of "P*A"] by presburger
  also have "... = (I' | I'  {0..<n}  card I' = k. J' | J'  {0..<m}  card J' = k.
    det (submatrix P I J') * det (submatrix A J' I') * det (submatrix Q I' J))"
    using det_subPA_rw by (simp add: semiring_0_class.sum_distrib_right)
  finally have det_rw: "det (submatrix B I J) = (I' | I'  {0..<n}  card I' = k.
    J' | J'  {0..<m}  card J' = k.
    det (submatrix P I J') * det (submatrix A J' I') * det (submatrix Q I' J))" .
  show ?thesis
  proof (unfold det_rw, (rule dvd_sum)+)
    fix I' J'
    assume I': "I'  {I'. I'  {0..<n}  card I' = k}"
      and J': "J'  {J'. J'  {0..<m}  card J' = k}"
    have "Gcd (minors A k) dvd  det (submatrix A J' I')"
      by (rule Gcd_dvd, unfold minors_def, insert A I' J', auto)
    then show "Gcd (minors A k) dvd det (submatrix P I J') * det (submatrix A J' I')
          * det (submatrix Q I' J)" by auto
  qed
qed

(*The conclusion could be simplified since we have S = I.*)
lemma det_minors_diagonal2:
  assumes dA: "diagonal_mat A" and A_carrier: "A  carrier_mat n m"
    and Ik: "card I = k" and Jk: "card J = k"
    and r: "I  {0..<n}"
    and c: "J  {0..<m}" and k: "k>0"
  shows "det (submatrix A I J) = 0  (S. S  {0..<min n m}  card S = k  S=I 
   (det (submatrix A I J) = (iS. A $$ (i,i))  det (submatrix A I J) = - (iS. A $$ (i,i))))"
  using Ik Jk r c k
proof (induct k arbitrary: I J)
 case 0
  then show ?case by auto
next
  case (Suc k)
  note cardI = Suc.prems(1)
  note cardJ = Suc.prems(2)
  note I = Suc.prems(3)
  note J = Suc.prems(4)
  have *: "{i. i < dim_row A  i  I} = I" using I Ik A_carrier carrier_mat_def by auto
  have **: "{j. j < dim_col A  j  J} = J" using J Jk A_carrier carrier_mat_def by auto
  show ?case
  proof (cases "k = 0")
    case True note k0 = True
    from this obtain a where aI: "I = {a}" using True cardI card_1_singletonE by auto
    from this obtain b where bJ: "J = {b}" using True cardJ card_1_singletonE by auto
    have an: "a<n" using aI I by auto
    have bm: "b<m" using bJ J by auto
    have sub_carrier: "submatrix A {a} {b}  carrier_mat 1 1"
      unfolding carrier_mat_def submatrix_def
      using * ** aI bJ by auto
    have 1: "det (submatrix A {a} {b}) = (submatrix A {a} {b}) $$ (0,0)"
      by (rule det_singleton[OF sub_carrier])
    have 2: "... = A $$ (a,b)"
      by (rule submatrix_singleton_index[OF A_carrier an bm])
    show ?thesis
    proof (cases "A $$ (a,b)  0")
      let ?S="{a}"
      case True
      hence ab: "a = b" using dA A_carrier an bm unfolding diagonal_mat_def carrier_mat_def by auto
      hence "?S  {0..<min n m}" using an bm by auto
      moreover have "det (submatrix A {a} {b}) = (i?S. A $$ (i, i))" using 1 2 ab by auto
      moreover have "card ?S = Suc k" using k0 by auto
      ultimately show ?thesis using an bm unfolding aI bJ by blast
    next
      case False
      then show ?thesis using 1 2 aI bJ by auto
    qed
  next
    case False
    hence k0: "0 < k" by simp
    have k: "k < min n m"
      by (metis I J cardI cardJ le_imp_less_Suc less_Suc_eq_le min.commute
          min_def not_less subset_eq_atLeast0_lessThan_card)
    have subIJ_carrier: "(submatrix A I J)  carrier_mat (Suc k) (Suc k)"
      unfolding carrier_mat_def using * ** cardI cardJ
      unfolding submatrix_def by auto
    obtain b' where b'k: "b' < Suc k" by auto
    let ?f="λi. submatrix A I J $$ (i, b') * cofactor (submatrix A I J) i b'"
    have det_rw: "det (submatrix A I J)
        = (i<Suc k. submatrix A I J $$ (i, b') * cofactor (submatrix A I J) i b')"
      by (rule laplace_expansion_column[OF subIJ_carrier b'k])
    show ?thesis
    proof (cases "a'<Suc k. submatrix A I J $$ (a',b')  0")
      case True
      obtain a' where sub_IJ_0: "submatrix A I J $$ (a',b')  0"
        and a'k: "a' < Suc k"
        and unique: "j. j<Suc k  submatrix A I J $$ (j,b')  0  j = a'"
        using diagonal_imp_submatrix_element_not0[OF dA A_carrier cardI cardJ I J b'k True] by auto
      have "submatrix A I J $$ (a', b') = A $$ (pick I a', pick J b')"
        by (rule submatrix_index, auto simp add: "*" a'k cardI "**" b'k cardJ)
      from this obtain a b where an: "a < n" and bm:  "b < m"
        and sub_index: "submatrix A I J $$ (a', b') = A $$ (a, b)"
        and pick_a: "pick I a' = a" and pick_b: "pick J b' = b"
        using * ** A_carrier a'k b'k cardI cardJ pick_le by fastforce
      obtain I' where aI': "I = insert a I'" and a_notin: "a  I'"
        by (metis Set.set_insert a'k cardI pick_a pick_in_set_le)
      obtain J' where bJ': "J = insert b J'" and b_notin: "b  J'"
        by (metis Set.set_insert b'k cardJ pick_b pick_in_set_le)
      have Suc_k0: "0 < Suc k" by simp
      have aI: "a  I" using aI' by auto
      have bJ: "b  J" using bJ' by auto
      have cardI':  "card I' = k"
        by (metis aI' a_notin cardI card.infinite card_insert_disjoint
            finite_insert nat.inject nat.simps(3))
      have cardJ':  "card J' = k"
        by (metis bJ' b_notin cardJ card.infinite card_insert_disjoint
            finite_insert nat.inject nat.simps(3))
      have I': "I'  {0..<n}" using I aI' by blast
      have J': "J'  {0..<m}" using J bJ' by blast
      have det_sub_I'J': "det (submatrix A I' J') = 0  (S{0..<min n m}. card S = k  S=I'
         (det (submatrix A I' J') = (iS. A $$ (i, i))
         det (submatrix A I' J') = - (iS. A $$ (i, i))))"
      proof (rule Suc.hyps[OF cardI' cardJ' _ _ k0])
        show "I'  {0..<n}" using I aI' by blast
        show "J'  {0..<m}" using J bJ' by blast
      qed
      have mat_delete_sub:
        "mat_delete (submatrix A (insert a I') (insert b J')) a' b' = submatrix A I' J'"
        by (rule mat_delete_submatrix_insert[OF A_carrier cardI' cardJ' I' J' an bm k
              a_notin b_notin a'k b'k],insert pick_a pick_b aI' bJ', auto)
      have set_rw: "{0..<Suc k} = insert a' ({0..<Suc k}-{a'})"
        by (simp add: a'k insert_absorb)
      have rw0: "sum ?f ({0..<Suc k}-{a'}) = 0" by (rule sum.neutral, insert unique, auto)
      have "det (submatrix A I J)
        = (i<Suc k. submatrix A I J $$ (i, b') * cofactor (submatrix A I J) i b')"
        by (rule laplace_expansion_column[OF subIJ_carrier b'k])
      also have "... = ?f a' + sum ?f ({0..<Suc k}-{a'})"
        by (metis (no_types, lifting) Diff_iff atLeast0LessThan finite_atLeastLessThan
            finite_insert set_rw singletonI sum.insert)
      also have "... = ?f a'" using rw0 unfolding cofactor_def by auto
      also have "... = submatrix A I J $$ (a', b') * ((-1) ^ (a' + b') * det (submatrix A I' J'))"
        unfolding cofactor_def using mat_delete_sub aI' bJ' by simp
      finally have det_submatrix_IJ: "det (submatrix A I J)
         = A $$ (a, b) * ((- 1) ^ (a' + b') * det (submatrix A I' J'))" unfolding sub_index .
      show ?thesis
      proof (cases "det (submatrix A I' J') = 0")
        case True
        then show ?thesis using det_submatrix_IJ by auto
      next
        case False note det_not0 = False
        from this obtain xs where prod_list_xs: "det (submatrix A I' J') = (ixs. A $$ (i, i))
           det (submatrix A I' J') = - (ixs. A $$ (i, i))"
          and xs: "xs{0..<min n m}"
          and length_xs: "card xs = k"
          and xs_I': "xs=I'"
          using det_sub_I'J' by blast
        let ?ys = "insert a xs"
        have a_notin_xs: "a  xs"
          by (simp add: xs_I' a_notin)
        have length_ys: "card ?ys = Suc k"
          using length_xs a_notin_xs by (simp add: card_ge_0_finite k0)
        have a_eq_b: "a=b"
          using A_carrier an bm sub_IJ_0 sub_index dA unfolding diagonal_mat_def by auto
        have A_aa_in: "A$$(a,a)  {A $$ (i, i) |i. i < min n m  A $$ (i, i)  0}"
          using a_eq_b an bm sub_IJ_0 sub_index by auto
        show ?thesis
        proof (cases "even (a'+b')")
          case True
          have det_submatrix_IJ: "det (submatrix A I J) = A $$ (a, b) * det (submatrix A I' J')"
            using det_submatrix_IJ True by auto
          show ?thesis
          proof (cases "det (submatrix A I' J') = (ixs. A $$ (i, i))")
            case True
            have "det (submatrix A I J) = (i?ys. A $$ (i, i))"
              using det_submatrix_IJ unfolding True a_eq_b
              by (metis (no_types, lifting) a_notin_xs a_eq_b
                  card_ge_0_finite k0 length_xs prod.insert)
            then show ?thesis using length_ys
              using a_eq_b an bm xs xs_I'
              by (simp add: aI')
          next
            case False
            hence "det (submatrix A I' J') = - (ixs. A $$ (i, i))" using prod_list_xs by simp
            hence "det (submatrix A I J) = -(i?ys. A $$ (i, i))" using det_submatrix_IJ a_eq_b
              by (metis (no_types, lifting) a_notin_xs card_ge_0_finite k0
                  length_xs mult_minus_right prod.insert)
            then show ?thesis using length_ys
              using a_eq_b an bm xs aI' xs_I' by force
          qed
        next
          case False
          have det_submatrix_IJ: "det (submatrix A I J) = A $$ (a, b) * - det (submatrix A I' J')"
            using det_submatrix_IJ False by auto
          show ?thesis
          proof (cases "det (submatrix A I' J') = (ixs. A $$ (i, i))")
            case True
            have "det (submatrix A I J) = - (i?ys. A $$ (i, i))"
              using det_submatrix_IJ unfolding True
              by (metis (no_types, lifting) a_eq_b a_notin_xs card_ge_0_finite k0
                  length_xs mult_minus_right prod.insert)
            then show ?thesis using length_ys
              using a_eq_b an bm xs aI' xs_I' by force
          next
            case False
            hence "det (submatrix A I' J') = - (ixs. A $$ (i, i))" using prod_list_xs by simp
            hence "det (submatrix A I J) = (i?ys. A $$ (i, i))" using det_submatrix_IJ
              by (metis (mono_tags, lifting) a_eq_b a_notin_xs card_ge_0_finite
                  equation_minus_iff k0 length_xs prod.insert)
            then show ?thesis using length_ys
              using a_eq_b an bm xs aI' xs_I' by force
          qed
        qed
      qed
    next
      case False
      have "sum ?f {0..<Suc k} = 0" by (rule sum.neutral, insert False, auto)
      thus ?thesis using det_rw
        by (simp add: atLeast0LessThan)
    qed
  qed
qed


subsection ‹Relating minors and GCD›

lemma diagonal_dvd_Gcd_minors:
  fixes A::"'a::{semiring_Gcd,comm_ring_1} mat"
  assumes A: "A  carrier_mat n m"
    and SNF_A: "Smith_normal_form_mat A"
shows "(i=0..<k. A $$ (i,i)) dvd Gcd (minors A k)"
proof (cases "k=0")
  case True
  then show ?thesis by auto
next
  case False
  hence k: "0<k" by simp
  show ?thesis
  proof (rule Gcd_greatest)
    have diag_A: "diagonal_mat A"
      using SNF_A unfolding Smith_normal_form_mat_def isDiagonal_mat_def diagonal_mat_def by auto
    fix b assume b_in_minors: "b  minors A k"
    show "(i = 0..<k. A $$ (i, i)) dvd b"
    proof (cases "b=0")
      case True
      then show ?thesis by auto
    next
      case False
     obtain I J where b: "b = det (submatrix A I J)" and I: "I  {0..<dim_row A} "
    and J: "J  {0..<dim_col A}" and Ik: "card I = k" and Jk: "card J = k"
       using b_in_minors  unfolding minors_def by blast
    obtain S where S: "S  {0..<min n m}" and Sk: "card S = k"
      and det_subS: "det (submatrix A I J) = (iS. A $$ (i,i))
         det (submatrix A I J) = -(iS. A $$ (i,i))"
      using det_minors_diagonal2[OF diag_A A Ik Jk _ _ k] I J A False b by auto
    obtain f where inj_f: "inj_on f {0..<k}" and fk_S: "f`{0..<k} = S"
      and i_fi: " (i{0..<k}. i  f i)" using exists_inj_ge_index[OF S Sk] by blast
    have "(i = 0..<k. A $$ (i, i)) dvd (i{0..<k}. A $$ (f i,f i))"
      by (rule prod_dvd_prod, rule SNF_divides_diagonal[OF A SNF_A], insert fk_S S i_fi, force+)
    also have "... = (if`{0..<k}. A $$ (i,i))"
      by (rule prod.reindex[symmetric, unfolded o_def, OF inj_f])
    also have "... = (iS. A $$ (i, i))" using fk_S by auto
    finally have *: "(i = 0..<k. A $$ (i, i)) dvd (iS. A $$ (i, i))" .
    show "(i = 0..<k. A $$ (i, i)) dvd b" using det_subS b * by auto
  qed
qed
qed


lemma Gcd_minors_dvd_diagonal:
  fixes A::"'a::{semiring_Gcd,comm_ring_1} mat"
  assumes A: "A  carrier_mat n m"
    and SNF_A: "Smith_normal_form_mat A"
    and k: "k  min n m"
  shows "Gcd (minors A k) dvd (i=0..<k. A $$ (i,i))"
proof (rule Gcd_dvd)
  define I where "I = {0..<k}"
  have "(i = 0..<k. A $$ (i, i)) = det (submatrix A I I)"
  proof -
    have sub_eq: "submatrix A I I = mat k k (λ(i, j). A $$ (i, j))"
    proof (rule eq_matI, auto)
      have "I = {i. i < dim_row A  i  I}" unfolding I_def using A k by auto
      hence ck: "card {i. i < dim_row A  i  I} = k"
        unfolding I_def using card_atLeastLessThan by presburger
      have "I = {i. i < dim_col A  i  I}" unfolding I_def using A k by auto
      hence ck2: "card {j. j < dim_col A  j  I} = k"
        unfolding I_def using card_atLeastLessThan by presburger
      show dr: "dim_row (submatrix A I I) = k" using ck unfolding submatrix_def by auto
      show dc: "dim_col (submatrix A I I) = k" using ck2 unfolding submatrix_def by auto
      fix i j assume i: "i < k" and j: "j < k"
      have p1: "pick I i = i"
      proof -
        have "{0..<i} = {a  I. a < i}" using I_def i by auto
        hence i_eq: "i = card {a  I. a < i}"
          by (metis card_atLeastLessThan diff_zero)
        have "pick I i = pick I (card {a  I. a < i})" using i_eq by simp
        also have "... = i" by (rule pick_card_in_set, insert i I_def, simp)
        finally show ?thesis .
      qed
      have p2: "pick I j = j"
      proof -
        have "{0..<j} = {a  I. a < j}" using I_def j by auto
        hence j_eq: "j = card {a  I. a < j}"
          by (metis card_atLeastLessThan diff_zero)
        have "pick I j = pick I (card {a  I. a < j})" using j_eq by simp
        also have "... = j" by (rule pick_card_in_set, insert j I_def, simp)
        finally show ?thesis .
      qed
      have "submatrix A I I $$ (i, j) = A $$ (pick I i, pick I j)"
      proof (rule submatrix_index)
        show "i < card {i. i < dim_row A  i  I}" by (metis dim_submatrix(1) dr i)
        show "j < card {j. j < dim_col A  j  I}" by (metis dim_submatrix(2) dc j)
      qed
      also have "... = A $$ (i,j)" using p1 p2 by simp
      finally show "submatrix A I I $$ (i, j) = A $$ (i, j)" .
    qed
    hence "det (submatrix A I I) = det (mat k k (λ(i, j). A $$ (i, j)))" by simp
    also have "... = prod_list (diag_mat (mat k k (λ(i, j). A $$ (i, j))))"
    proof (rule det_upper_triangular)
      show "mat k k (λ(i, j). A $$ (i, j))  carrier_mat k k" by auto
      show "upper_triangular (Matrix.mat k k (λ(i, j). A $$ (i, j)))"
        using SNF_A A k unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto
    qed
    also have "... = (i = 0..<k. A $$ (i, i))"
      by (metis (mono_tags, lifting) atLeastLessThan_iff dim_row_mat(1) index_mat(1)
          prod.cong prod_list_diag_prod split_conv)
    finally show ?thesis ..
  qed
  moreover have "I  {0..<dim_row A}" using k A I_def by auto
  moreover have "I  {0..<dim_col A}" using k A I_def by auto
  moreover have "card I = k" using I_def by auto
  ultimately show "(i = 0..<k. A $$ (i, i))  minors A k" unfolding minors_def by auto
qed



lemma Gcd_minors_A_dvd_Gcd_minors_PAQ:
 fixes A::"'a::{semiring_Gcd,comm_ring_1} mat"
 assumes A: "A  carrier_mat m n"
    and P: "P  carrier_mat m m" and Q: "Q  carrier_mat n n"
  shows "Gcd (minors A k) dvd Gcd (minors (P*A*Q) k)"
proof (rule Gcd_greatest)
  let ?B="(P * A * Q)"
  fix b assume "b  minors ?B k"
  from this  obtain I J where b: "b = det (submatrix ?B I J)" and I: "I  {0..<dim_row ?B}"
    and J: "J  {0..<dim_col ?B}" and Ik: "card I = k" and Jk: "card J = k"
    unfolding minors_def by blast
  have "Gcd (minors A k) dvd det (submatrix ?B I J)"
    by (rule Gcd_minors_dvd[OF _ P A Q _ _ Ik Jk], insert A I J P Q, auto)
  thus "Gcd (minors A k) dvd b" using b by simp
qed


lemma Gcd_minors_PAQ_dvd_Gcd_minors_A:
 fixes A::"'a::{semiring_Gcd,comm_ring_1} mat"
 assumes A: "A  carrier_mat m n"
    and P: "P  carrier_mat m m"
    and Q: "Q  carrier_mat n n"
    and inv_P: "invertible_mat P"
    and inv_Q: "invertible_mat Q"
  shows "Gcd (minors (P*A*Q) k) dvd Gcd (minors A k)"
proof (rule Gcd_greatest)
  let ?B = "P * A * Q"
  fix b assume "b  minors A k"
  from this obtain I J where b: "b = det (submatrix A I J)" and I: "I  {0..<dim_row A} "
    and J: "J  {0..<dim_col A}" and Ik: "card I = k" and Jk: "card J = k"
    unfolding minors_def by blast
  obtain P' where PP': "inverts_mat P P'" and P'P: "inverts_mat P' P"
    using inv_P unfolding invertible_mat_def by auto
  obtain Q' where QQ': "inverts_mat Q Q'" and Q'Q: "inverts_mat Q' Q"
    using inv_Q unfolding invertible_mat_def by auto
  have P': "P'  carrier_mat m m" using PP' P'P unfolding inverts_mat_def
    by (metis P carrier_matD(1) carrier_matD(2) carrier_matI index_mult_mat(3) index_one_mat(3))
  have Q': "Q'  carrier_mat n n"
    using QQ' Q'Q unfolding inverts_mat_def
    by (metis Q carrier_matD(1) carrier_matD(2) carrier_matI index_mult_mat(3) index_one_mat(3))
  have rw: "P' *?B *Q' = A"
  proof -
    have f1: "P' * P = 1m m"
      by (metis (no_types) P' P'P carrier_matD(1) inverts_mat_def)
    have *: "P' * P * A = P' * (P * A)"
      by (meson A P P' assoc_mult_mat)
    have " P' * (P * A * Q) * Q' =  P' * P * A * Q * Q'"
      by (smt A P P' Q assoc_mult_mat mult_carrier_mat)
    also have "... =  P' * P * (A * Q * Q')"
      using A P P' Q Q' f1 * by auto
    also have "... = A * Q * Q'" using P'P A P' unfolding inverts_mat_def by auto
    also have "... = A" using QQ' A Q' Q unfolding inverts_mat_def by auto
    finally show ?thesis .
  qed
  have "Gcd (minors ?B k) dvd det (submatrix (P'*?B*Q') I J)"
    by (rule Gcd_minors_dvd[OF _ P' _ Q' _ _ Ik Jk], insert P A Q I J, auto)
  also have "... = det (submatrix A I J)" using rw by simp
  finally show "Gcd (minors ?B k) dvd b" using b by simp
qed

lemma Gcd_minors_dvd_diag_PAQ:
  fixes P A Q::"'a::{semiring_Gcd,comm_ring_1} mat"
 assumes A: "A  carrier_mat m n"
    and P: "P  carrier_mat m m"
    and Q: "Q  carrier_mat n n"
    and SNF: "Smith_normal_form_mat (P*A*Q)"
    and k: "kmin m n"
  shows "Gcd (minors A k) dvd (i=0..<k. (P * A * Q) $$ (i,i))"
proof -
  have "Gcd (minors A k) dvd Gcd (minors (P * A * Q) k)"
    by (rule Gcd_minors_A_dvd_Gcd_minors_PAQ[OF A P Q])
  also have "... dvd (i=0..<k. (P*A*Q) $$ (i,i))"
    by (rule Gcd_minors_dvd_diagonal[OF _ SNF k], insert P A Q, auto)
  finally show ?thesis .
qed


lemma diag_PAQ_dvd_Gcd_minors:
  fixes P A Q::"'a::{semiring_Gcd,comm_ring_1} mat"
 assumes A: "A  carrier_mat m n"
    and P: "P  carrier_mat m m"
    and Q: "Q  carrier_mat n n"
    and inv_P: "invertible_mat P"
    and inv_Q: "invertible_mat Q"
    and SNF: "Smith_normal_form_mat (P*A*Q)"
  shows "(i=0..<k. (P * A * Q) $$ (i,i)) dvd Gcd (minors A k)"
proof -
  have "(i=0..<k. (P*A*Q) $$ (i,i)) dvd Gcd (minors (P * A * Q) k)"
    by (rule diagonal_dvd_Gcd_minors[OF _ SNF], auto)
  also have "... dvd Gcd (minors A k)"
    by (rule Gcd_minors_PAQ_dvd_Gcd_minors_A[OF _ _ _ inv_P inv_Q], insert P A Q, auto)
  finally show ?thesis .
qed


(*This lemma requires semidom in order to apply prod_zero_iff*)
lemma Smith_prod_zero_imp_last_zero:
  fixes A::"'a::{semidom,comm_ring_1} mat"
  assumes  A: "A  carrier_mat m n"
    and SNF: "Smith_normal_form_mat A"
    and prod_0: "(j=0..<Suc i. A $$ (j,j)) = 0"
  and i: "i<min m n"
  shows "A $$(i,i) = 0"
proof -
  obtain j where Ajj: "A$$(j,j) = 0" and j: "j<Suc i" using prod_0 prod_zero_iff by auto
  show "A $$(i,i) = 0" by (rule Smith_zero_imp_zero[OF A SNF Ajj i], insert j, auto)
qed

subsection ‹Final theorem›

lemma Smith_normal_form_uniqueness_aux:
  fixes P A Q::"'a::{idom,semiring_Gcd} mat"
  assumes A: "A  carrier_mat m n"
  (*PAQ = B with B in SNF and P,Q invertible matrices*)
  and P: "P  carrier_mat m m"
  and Q: "Q  carrier_mat n n"
  and inv_P: "invertible_mat P"
  and inv_Q: "invertible_mat Q"
  and PAQ_B: "P*A*Q = B"
  and SNF: "Smith_normal_form_mat B"
  (*P'AQ' = B' with B' in SNF and P',Q' invertible matrices*)
  and P': "P'  carrier_mat m m"
  and Q': "Q'  carrier_mat n n"
  and inv_P': "invertible_mat P'"
  and inv_Q': "invertible_mat Q'"
  and P'AQ'_B': "P'*A*Q' = B'"
  and SNF_B': "Smith_normal_form_mat B'"
  and k: "k<min m n"
shows "ik. B$$(i,i) dvd B'$$(i,i)  B'$$(i,i) dvd B$$(i,i)"
proof (rule allI, rule impI)
  fix i assume ik: "i  k"
  show " B $$ (i, i) dvd B' $$ (i, i)  B' $$ (i, i) dvd B $$ (i, i)"
  proof -
    let ?ΠBi = "(i=0..<i. B $$ (i,i))"
    let ?ΠB'i = "(i=0..<i. B' $$ (i,i))"
    have "?ΠB'i dvd Gcd (minors A i)"
      by (unfold P'AQ'_B'[symmetric], rule diag_PAQ_dvd_Gcd_minors[OF A P' Q' inv_P' inv_Q'],
          insert P'AQ'_B' SNF_B' ik k, auto )
    also have "... dvd ?ΠBi"
      by (unfold PAQ_B[symmetric], rule Gcd_minors_dvd_diag_PAQ[OF A P Q],
          insert PAQ_B SNF ik k, auto)
    finally have B'_i_dvd_B_i: "?ΠB'i dvd ?ΠBi" .
    have "?ΠBi dvd Gcd (minors A i)"
      by (unfold PAQ_B[symmetric], rule diag_PAQ_dvd_Gcd_minors[OF A P Q inv_P inv_Q],
          insert PAQ_B SNF ik k, auto )
    also have "... dvd ?ΠB'i"
      by (unfold P'AQ'_B'[symmetric], rule Gcd_minors_dvd_diag_PAQ[OF A P' Q'],
          insert P'AQ'_B' SNF_B' ik k, auto)
    finally have B_i_dvd_B'_i: "?ΠBi dvd ?ΠB'i" .
    let ?ΠB_Suc = "(i=0..<Suc i. B $$ (i,i))"
    let ?ΠB'_Suc = "(i=0..<Suc i. B' $$ (i,i))"
    have "?ΠB'_Suc dvd Gcd (minors A (Suc i))"
      by (unfold P'AQ'_B'[symmetric], rule diag_PAQ_dvd_Gcd_minors[OF A P' Q' inv_P' inv_Q'],
          insert P'AQ'_B' SNF_B' ik k, auto )
    also have "... dvd ?ΠB_Suc"
      by (unfold PAQ_B[symmetric], rule Gcd_minors_dvd_diag_PAQ[OF A P Q],
          insert PAQ_B SNF ik k, auto)
    finally have 3: "?ΠB'_Suc dvd ?ΠB_Suc" .
    have "?ΠB_Suc dvd Gcd (minors A (Suc i))"
      by (unfold PAQ_B[symmetric], rule diag_PAQ_dvd_Gcd_minors[OF A P Q inv_P inv_Q],
          insert PAQ_B SNF ik k, auto )
    also have "... dvd ?ΠB'_Suc"
      by (unfold P'AQ'_B'[symmetric], rule Gcd_minors_dvd_diag_PAQ[OF A P' Q'],
          insert P'AQ'_B' SNF_B' ik k, auto)
    finally have 4: "?ΠB_Suc dvd ?ΠB'_Suc" .
    show ?thesis
    proof (cases "?ΠB_Suc = 0")
      case True
      have True2: "?ΠB'_Suc = 0" using 4 True by fastforce
      have "B$$(i,i) = 0"
        by (rule Smith_prod_zero_imp_last_zero[OF _ SNF True], insert ik k PAQ_B P Q, auto)
      moreover have "B'$$(i,i) = 0"
        by (rule Smith_prod_zero_imp_last_zero[OF _ SNF_B' True2],
            insert ik k P'AQ'_B' P' Q', auto)
      ultimately show ?thesis by auto
    next
      case False
      have "u. u dvd 1  ?ΠB'i = u * ?ΠBi"
        by (rule dvd_associated2[OF B'_i_dvd_B_i B_i_dvd_B'_i], insert False B'_i_dvd_B_i, force)
      from this obtain u where eq1: "(i=0..<i. B' $$ (i,i)) = u * (i=0..<i. B $$ (i,i))"
        and u_dvd_1: "u dvd 1" by blast
      have "u. u dvd 1  ?ΠB_Suc = u * ?ΠB'_Suc"
        by (rule dvd_associated2[OF 4 3 False])
      from this obtain w where eq2: "(i=0..<Suc i. B $$ (i,i)) = w * (i=0..<Suc i. B' $$ (i,i))"
        and w_dvd_1: "w dvd 1" by blast
      have "B $$ (i, i) * (i=0..<i. B $$ (i,i)) = (i=0..<Suc i. B $$ (i,i))"
        by (simp add: prod.atLeast0_lessThan_Suc ik)
      also have "... = w * (i=0..<Suc i. B' $$ (i,i))" unfolding eq2 by auto
      also have "... = w * (B' $$ (i,i) * (i=0..<i. B' $$ (i,i)))"
        by (simp add: prod.atLeast0_lessThan_Suc ik)
      also have "... = w * (B' $$ (i,i) * u * (i=0..<i. B $$ (i,i)))"
        unfolding eq1 by auto
      finally have "B $$ (i,i) = w * u * B' $$ (i,i)"
        using False by auto
      moreover have "w*u dvd 1" using u_dvd_1 w_dvd_1 by auto
      ultimately have "u. is_unit u  B $$ (i, i) = u * B' $$ (i, i)" by auto
      thus ?thesis using dvd_associated2 by force
    qed
  qed
qed


lemma Smith_normal_form_uniqueness:
  fixes P A Q::"'a::{idom,semiring_Gcd} mat"
  assumes A: "A  carrier_mat m n"
    (*PAQ = B with B in SNF and P,Q invertible matrices*)
    and P: "P  carrier_mat m m"
    and Q: "Q  carrier_mat n n"
    and inv_P: "invertible_mat P"
    and inv_Q: "invertible_mat Q"
    and PAQ_B: "P*A*Q = B"
    and SNF: "Smith_normal_form_mat B"
    (*P'AQ' = B' with B' in SNF and P',Q' invertible matrices*)
    and P': "P'  carrier_mat m m"
    and Q': "Q'  carrier_mat n n"
    and inv_P': "invertible_mat P'"
    and inv_Q': "invertible_mat Q'"
    and P'AQ'_B': "P'*A*Q' = B'"
    and SNF_B': "Smith_normal_form_mat B'"
    and i: "i < min m n"
  shows "u. u dvd 1  B $$ (i,i) = u * B' $$ (i,i)"
proof (cases "B $$ (i,i) = 0")
  case True
  let ?ΠB_Suc = "(i=0..<Suc i. B $$ (i,i))"
  let ?ΠB'_Suc = "(i=0..<Suc i. B' $$ (i,i))"
  have "?ΠB_Suc dvd Gcd (minors A (Suc i))"
    by (unfold PAQ_B[symmetric], rule diag_PAQ_dvd_Gcd_minors[OF A P Q inv_P inv_Q],
        insert PAQ_B SNF i, auto)
  also have "... dvd ?ΠB'_Suc"
    by (unfold P'AQ'_B'[symmetric], rule Gcd_minors_dvd_diag_PAQ[OF A P' Q'],
        insert P'AQ'_B' SNF_B' i, auto)
  finally have 4: "?ΠB_Suc dvd ?ΠB'_Suc" .
  have prod0: "?ΠB_Suc=0" using True by auto
  have True2: "?ΠB'_Suc = 0" using 4 by (metis dvd_0_left_iff prod0)
  have "B'$$(i,i) = 0"
    by (rule Smith_prod_zero_imp_last_zero[OF _ SNF_B' True2],
        insert i P'AQ'_B' P' Q', auto)
  thus ?thesis using True by auto
next
  case False
  have "ai. B$$(a,a) dvd B'$$(a,a)  B'$$(a,a) dvd B$$(a,a)"
    by (rule Smith_normal_form_uniqueness_aux[OF assms])
  hence "B$$(i,i) dvd B'$$(i,i)  B'$$(i,i) dvd B$$(i,i)" using i by auto
  thus ?thesis using dvd_associated2 False by blast
qed

text ‹The final theorem, moved to HOL Analysis›

lemma Smith_normal_form_uniqueness_HOL_Analysis:
  fixes A::"'a::{idom,semiring_Gcd}^'m::mod_type^'n::mod_type"
  and P P'::"'a^'n::mod_type^'n::mod_type"
  and Q Q'::"'a^'m::mod_type^'m::mod_type"
  assumes
    (*PAQ = B with B in SNF and P,Q invertible matrices*)
    inv_P: "invertible P"
    and inv_Q: "invertible Q"
    and PAQ_B: "P**A**Q = B"
    and SNF: "Smith_normal_form B"
    (*P'AQ' = B' with B' in SNF and P',Q' invertible matrices*)
    and inv_P': "invertible P'"
    and inv_Q': "invertible Q'"
    and P'AQ'_B': "P'**A**Q' = B'"
    and SNF_B': "Smith_normal_form B'"
    and i: "i < min (nrows A) (ncols A)"
  shows "u. u dvd 1  B $h Mod_Type.from_nat i $h Mod_Type.from_nat i
  = u * B' $h Mod_Type.from_nat i $h Mod_Type.from_nat i"
proof -
  let ?P = "Mod_Type_Connect.from_hmam P"
  let ?A = "Mod_Type_Connect.from_hmam A"
  let ?Q = "Mod_Type_Connect.from_hmam Q"
  let ?B = "Mod_Type_Connect.from_hmam B"
  let ?P' = "Mod_Type_Connect.from_hmam P'"
  let ?Q' = "Mod_Type_Connect.from_hmam Q'"
  let ?B' = "Mod_Type_Connect.from_hmam B'"
  let ?i = "(Mod_Type.from_nat i)::'n"
  let ?i' = "(Mod_Type.from_nat i)::'m"
  have [transfer_rule]: "Mod_Type_Connect.HMA_M ?P P" by (simp add: Mod_Type_Connect.HMA_M_def)
  have [transfer_rule]: "Mod_Type_Connect.HMA_M ?A A" by (simp add: Mod_Type_Connect.HMA_M_def)
  have [transfer_rule]: "Mod_Type_Connect.HMA_M ?Q Q" by (simp add: Mod_Type_Connect.HMA_M_def)
  have [transfer_rule]: "Mod_Type_Connect.HMA_M ?B B" by (simp add: Mod_Type_Connect.HMA_M_def)
  have [transfer_rule]: "Mod_Type_Connect.HMA_M ?P' P'" by (simp add: Mod_Type_Connect.HMA_M_def)
  have [transfer_rule]: "Mod_Type_Connect.HMA_M ?Q' Q'" by (simp add: Mod_Type_Connect.HMA_M_def)
  have [transfer_rule]: "Mod_Type_Connect.HMA_M ?B' B'" by (simp add: Mod_Type_Connect.HMA_M_def)
  have [transfer_rule]: "Mod_Type_Connect.HMA_I i ?i"
    by (metis Mod_Type_Connect.HMA_I_def i min.strict_boundedE
        mod_type_class.to_nat_from_nat_id nrows_def)
  have [transfer_rule]: "Mod_Type_Connect.HMA_I i ?i'"
       by (metis Mod_Type_Connect.HMA_I_def i min.strict_boundedE
        mod_type_class.to_nat_from_nat_id ncols_def)
  have i2: "i < min CARD('m) CARD('n)" using i unfolding nrows_def ncols_def by auto
  have "u. u dvd 1  ?B $$(i,i) = u * ?B' $$ (i,i)"
  proof (rule Smith_normal_form_uniqueness[of _ "CARD('n)" "CARD('m)"])
    show "?P*?A*?Q=?B" using PAQ_B by (transfer', auto)
    show "Smith_normal_form_mat ?B" using SNF by (transfer', auto)
    show "?P'*?A*?Q'=?B'" using P'AQ'_B' by (transfer', auto)
    show "Smith_normal_form_mat ?B'" using SNF_B' by (transfer', auto)
    show "invertible_mat ?P" using inv_P by (transfer, auto)
    show "invertible_mat ?P'" using inv_P' by (transfer, auto)
    show "invertible_mat ?Q" using inv_Q by (transfer, auto)
    show "invertible_mat ?Q'" using inv_Q' by (transfer, auto)
  qed (insert i2, auto)
  hence "u. u dvd 1  (index_hma B ?i ?i') = u * (index_hma B' ?i ?i')" by (transfer', rule)
  thus ?thesis unfolding index_hma_def by simp
qed

subsection ‹Uniqueness fixing a complete set of non-associates›

definition "Smith_normal_form_wrt A 𝒬 = (
    (a b. Mod_Type.to_nat a = Mod_Type.to_nat b  Mod_Type.to_nat a + 1 < nrows A
             Mod_Type.to_nat b + 1 < ncols A  A $h a $h b dvd A $h (a+1) $h (b+1))
     isDiagonal A  Complete_set_non_associates 𝒬
     (a b. Mod_Type.to_nat a = Mod_Type.to_nat b  Mod_Type.to_nat a < min (nrows A) (ncols A)
        Mod_Type.to_nat b < min (nrows A) (ncols A)  A $h a $h b  𝒬)
  )"

lemma Smith_normal_form_wrt_uniqueness_HOL_Analysis:
  fixes A::"'a::{idom,semiring_Gcd}^'m::mod_type^'n::mod_type"
  and P P'::"'a^'n::mod_type^'n::mod_type"
  and Q Q'::"'a^'m::mod_type^'m::mod_type"
  assumes
    (*PAQ = S with S in SNF and P,Q invertible matrices*)
    P: "invertible P"
    and Q: "invertible Q"
    and PAQ_S: "P**A**Q = S"
    and SNF: "Smith_normal_form_wrt S 𝒬"
    (*P'AQ' = S' with S' in SNF and P',Q' invertible matrices*)
    and P': "invertible P'"
    and Q': "invertible Q'"
    and P'AQ'_S': "P'**A**Q' = S'"
    and SNF_S': "Smith_normal_form_wrt S' 𝒬"
  shows "S = S'"
proof -
  have "S $h i $h j = S' $h i $h j" for i j
  proof (cases "Mod_Type.to_nat i  Mod_Type.to_nat j")
  case True
    then show ?thesis using SNF SNF_S' unfolding Smith_normal_form_wrt_def isDiagonal_def by auto
  next
    case False
    let ?i = "Mod_Type.to_nat i"
    let ?j = "Mod_Type.to_nat j"
    have complete_set: "Complete_set_non_associates 𝒬"
      using SNF_S' unfolding Smith_normal_form_wrt_def by simp
    have ij: "?i = ?j" using False by auto
    show ?thesis
    proof (rule ccontr)
      assume d: "S $h i $h j  S' $h i $h j"
      have n: "normalize (S $h i $h j)  normalize (S' $h i $h j)"
      proof (rule in_Ass_not_associated[OF complete_set _ _ d])
        show "S $h i $h j  𝒬" using SNF unfolding Smith_normal_form_wrt_def
          by (metis False min_less_iff_conj mod_type_class.to_nat_less_card ncols_def nrows_def)
        show "S' $h i $h j  𝒬" using SNF_S' unfolding Smith_normal_form_wrt_def
          by (metis False min_less_iff_conj mod_type_class.to_nat_less_card ncols_def nrows_def)
      qed
      have "u. u dvd 1  S $h i $h j = u * S' $h i $h j"
      proof -
        have "u. u dvd 1  S $h Mod_Type.from_nat ?i $h Mod_Type.from_nat ?i
          = u * S' $h Mod_Type.from_nat ?i $h Mod_Type.from_nat ?i"
        proof (rule Smith_normal_form_uniqueness_HOL_Analysis[OF P Q PAQ_S _ P' Q' P'AQ'_S' _])
          show "Smith_normal_form S" and "Smith_normal_form S'"
            using SNF SNF_S' Smith_normal_form_def Smith_normal_form_wrt_def by blast+
          show "?i < min (nrows A) (ncols A)"
            by (metis ij min_less_iff_conj mod_type_class.to_nat_less_card ncols_def nrows_def)
        qed
        thus ?thesis using False by auto
      qed
      from this obtain u where "is_unit u" and "S $h i $h j = u * S' $h i $h j" by auto
      thus False using n
        by (simp add: normalize_1_iff normalize_mult)
    qed
  qed
  thus ?thesis by vector
qed


end

Theory Cauchy_Binet_HOL_Analysis

(*
    Author:      Jose Divasón
    Email:       jose.divason@unirioja.es
*)

section ‹The Cauchy--Binet formula in HOL Analysis›

theory Cauchy_Binet_HOL_Analysis
  imports
    Cauchy_Binet
    Perron_Frobenius.HMA_Connect
begin

subsection ‹Definition of submatrices in HOL Analysis›

definition submatrix_hma :: "'a^'nc^'nrnat setnat set('a^'nc2^'nr2)"
  where "submatrix_hma A I J = (χ a b. A $h (from_nat (pick I (to_nat a))) $h (from_nat (pick J (to_nat b))))"

context includes lifting_syntax
begin

context
  fixes I::"nat set" and J::"nat set"
  assumes I: "card {i. i < CARD('nr::finite)  i  I} = CARD('nr2::finite)"
  assumes J: "card {i. i < CARD('nc::finite)  i  J} = CARD('nc2::finite)"
begin

lemma HMA_submatrix[transfer_rule]: "(HMA_M ===> HMA_M) (λA. submatrix A I J)
  ((λA. submatrix_hma A I J):: 'a^ 'nc ^ 'nr  'a ^ 'nc2 ^ 'nr2)"
proof (intro rel_funI, goal_cases)
  case (1 A B)
  note relAB[transfer_rule] = this
  show ?case unfolding  HMA_M_def
  proof (rule eq_matI, auto)
    show "dim_row (submatrix A I J) = CARD('nr2)"
      unfolding submatrix_def
      using I dim_row_transfer_rule relAB by force
    show "dim_col (submatrix A I J) = CARD('nc2)"
      unfolding submatrix_def
      using J dim_col_transfer_rule relAB by force
    let ?B="(submatrix_hma B I J)::'a ^ 'nc2 ^ 'nr2"
    fix i j assume i: "i < CARD('nr2)" and
           j: "j < CARD('nc2)"
    have i2: "i < card {i. i < dim_row A  i  I}"
      using I dim_row_transfer_rule i relAB by fastforce
    have j2: "j < card {j. j < dim_col A  j  J}"
      using J dim_col_transfer_rule j relAB by fastforce
    let ?i = "(from_nat (pick I i))::'nr"
    let ?j = "(from_nat (pick J j))::'nc"
    let ?i' = "Bij_Nat.to_nat ((Bij_Nat.from_nat i)::'nr2)"
    let ?j' = "Bij_Nat.to_nat ((Bij_Nat.from_nat j)::'nc2)"
    have i': "?i' = i" by (rule to_nat_from_nat_id[OF i])
    have j': "?j' = j" by (rule to_nat_from_nat_id[OF j])
    let ?f = "(λ(i, j).
         B $h Bij_Nat.from_nat (pick I (Bij_Nat.to_nat ((Bij_Nat.from_nat i)::'nr2))) $h
         Bij_Nat.from_nat (pick J (Bij_Nat.to_nat ((Bij_Nat.from_nat j)::'nc2))))"
    have [transfer_rule]: "HMA_I (pick I i) ?i"
      by (simp add: Bij_Nat.to_nat_from_nat_id I i pick_le HMA_I_def)
    have [transfer_rule]: "HMA_I (pick J j) ?j"
      by (simp add: Bij_Nat.to_nat_from_nat_id J j pick_le HMA_I_def)
    have "submatrix A I J $$ (i, j) = A $$ (pick I i, pick J j)" by (rule submatrix_index[OF i2 j2])
    also have "... = index_hma B ?i ?j" by (transfer, simp)
    also have "... =  B $h Bij_Nat.from_nat (pick I (Bij_Nat.to_nat ((Bij_Nat.from_nat i)::'nr2))) $h
         Bij_Nat.from_nat (pick J (Bij_Nat.to_nat ((Bij_Nat.from_nat j)::'nc2)))"
      unfolding i' j' index_hma_def by auto
    also have "... = ?f (i,j)" by auto
    also have "... = Matrix.mat CARD('nr2) CARD('nc2) ?f $$ (i, j)"
      by (rule index_mat[symmetric, OF i j])
    also have "... = from_hmam ?B $$ (i, j)"
      unfolding from_hmam_def submatrix_hma_def by auto
    finally show "submatrix A I J $$ (i, j) = from_hmam ?B $$ (i, j)" .
  qed
qed

end
end


subsection ‹Transferring the proof from JNF to HOL Analysis›

lemma Cauchy_Binet_HOL_Analysis:
  fixes A::"'a::comm_ring_1^'m^'n" and B::"'a^'n^'m"
  shows "Determinants.det (A**B) = (I{I. I{0..<ncols A}  card I=nrows A}.
         Determinants.det ((submatrix_hma A UNIV I)::'a^'n^'n) *
         Determinants.det ((submatrix_hma B I UNIV)::'a^'n^'n))"
proof -
  let ?A = "(from_hmam A)"
  let ?B = "(from_hmam B)"
  have relA[transfer_rule]: "HMA_M ?A A" unfolding HMA_M_def by simp
  have relB[transfer_rule]: "HMA_M ?B B" unfolding HMA_M_def by simp
  have "(I{I. I{0..<ncols A}  card I = nrows A}.
         Determinants.det ((submatrix_hma A UNIV I)::'a^'n^'n) *
         Determinants.det ((submatrix_hma B I UNIV)::'a^'n^'n)) =
          (I{I. I{0..<ncols A}  card I=nrows A}. det (submatrix ?A UNIV I)
        * det (submatrix ?B I UNIV))"
  proof (rule sum.cong)
    fix I assume I: "I {I. I{0..<ncols A}  card I=nrows A}"
    let ?sub_A= "((submatrix_hma A UNIV I)::'a^'n^'n)"
    let ?sub_B= "((submatrix_hma B I UNIV)::'a^'n^'n)"
    have c1: "card {i. i < CARD('n)  i  UNIV} = CARD('n)" using I by auto
    have c2: "card {i. i < CARD('m)  i  I} = CARD('n)"
    proof -
      have "I = {i. i < CARD('m)  i  I}" using I unfolding nrows_def ncols_def by auto
      thus ?thesis using I nrows_def by auto
    qed
    have [transfer_rule]: "HMA_M (submatrix ?A UNIV I) ?sub_A"
      using HMA_submatrix[OF c1 c2] relA unfolding rel_fun_def by auto
    have [transfer_rule]: "HMA_M (submatrix ?B I UNIV) ?sub_B"
      using HMA_submatrix[OF c2 c1] relB unfolding rel_fun_def by auto
    show "Determinants.det ?sub_A * Determinants.det ?sub_B
      = det (submatrix ?A UNIV I) * det (submatrix ?B I UNIV)" by (transfer', auto)
  qed (auto)
  also have "... = det (?A*?B)"
    by (rule Cauchy_Binet[symmetric], unfold nrows_def ncols_def, auto)
  also have "... = Determinants.det (A**B)" by (transfer', auto)
  finally show ?thesis ..
qed

end

Theory Diagonalize

(*
    Author:      Jose Divasón
    Email:       jose.divason@unirioja.es           
*)

section ‹Diagonalizing matrices in JNF and HOL Analysis›

theory Diagonalize
  imports Admits_SNF_From_Diagonal_Iff_Bezout_Ring
begin


text ‹This section presents a @{text "locale"} that assumes a sound operation to make a matrix
diagonal. Then, the result is transferred to HOL Analysis.›

subsection ‹Diagonalizing matrices in JNF›

text ‹We assume a @{text "diagonalize_JNF"} operation in JNF, which is applied to matrices over
a B\'ezout ring. However, probably a more restrictive type class is required.›

locale diagonalize =
  fixes diagonalize_JNF :: "'a::bezout_ring mat  'a bezout  ('a mat × 'a mat × 'a mat)"
  assumes soundness_diagonalize_JNF: 
    "A bezout. A  carrier_mat m n  is_bezout_ext bezout 
     (case diagonalize_JNF A bezout of (P,S,Q)     
      P  carrier_mat m m  Q  carrier_mat n n  S  carrier_mat m n 
       invertible_mat P  invertible_mat Q  isDiagonal_mat S  S = P*A*Q)"
begin

lemma soundness_diagonalize_JNF':
  fixes A::"'a mat"
  assumes "is_bezout_ext bezout" and "A  carrier_mat m n"
  and "diagonalize_JNF A bezout = (P,S,Q)"
  shows "P  carrier_mat m m  Q  carrier_mat n n  S  carrier_mat m n 
       invertible_mat P  invertible_mat Q  isDiagonal_mat S  S = P*A*Q"
  using soundness_diagonalize_JNF assms unfolding case_prod_beta by (metis fst_conv snd_conv)


subsection ‹Implementation and soundness result moved to HOL Analysis.›

definition diagonalize :: "'a::bezout_ring ^ 'nc :: mod_type ^ 'nr :: mod_type
      'a bezout  
    (('a ^ 'nr :: mod_type ^ 'nr :: mod_type) 
    × ('a ^ 'nc :: mod_type ^ 'nr :: mod_type) 
    × ('a ^ 'nc :: mod_type ^ 'nc :: mod_type))"
  where "diagonalize A bezout = (
    let (P,S,Q) = diagonalize_JNF (Mod_Type_Connect.from_hmam A) bezout
    in (Mod_Type_Connect.to_hmam P,Mod_Type_Connect.to_hmam S,Mod_Type_Connect.to_hmam Q)
  )"

lemma soundness_diagonalize:
  assumes b: "is_bezout_ext bezout"
  and d: "diagonalize A bezout = (P,S,Q)"
shows "invertible P  invertible Q  isDiagonal S  S = P**A**Q"
proof -
  define A' where "A' = Mod_Type_Connect.from_hmam A"  
  obtain P' S' Q' where d_JNF: "(P',S',Q') = diagonalize_JNF A' bezout"
    by (metis prod_cases3)
  define m and n where "m = dim_row A'" and "n = dim_col A'"
  hence A': "A'  carrier_mat m n" by auto
  have res_JNF: "P'  carrier_mat m m  Q'  carrier_mat n n  S'  carrier_mat m n 
       invertible_mat P'  invertible_mat Q'  isDiagonal_mat S'  S' = P'*A'*Q'"
    by (rule soundness_diagonalize_JNF'[OF b A' d_JNF[symmetric]])
  have "Mod_Type_Connect.to_hmam P' = P" using d unfolding diagonalize_def Let_def
    by (metis A'_def d_JNF fst_conv old.prod.case)
  hence "P' = Mod_Type_Connect.from_hmam P" using A'_def m_def res_JNF by auto
  hence [transfer_rule]: "Mod_Type_Connect.HMA_M P' P" 
    unfolding Mod_Type_Connect.HMA_M_def by auto
  have "Mod_Type_Connect.to_hmam Q' = Q" using d unfolding diagonalize_def Let_def
    by (metis A'_def d_JNF snd_conv old.prod.case)
  hence "Q' = Mod_Type_Connect.from_hmam Q" using A'_def n_def res_JNF by auto
  hence [transfer_rule]: "Mod_Type_Connect.HMA_M Q' Q"
    unfolding Mod_Type_Connect.HMA_M_def by auto
  have "Mod_Type_Connect.to_hmam S' = S" using d unfolding diagonalize_def Let_def
    by (metis A'_def d_JNF snd_conv old.prod.case)
  hence "S' = Mod_Type_Connect.from_hmam S" using A'_def m_def n_def res_JNF by auto
  hence [transfer_rule]: "Mod_Type_Connect.HMA_M S' S"
    unfolding Mod_Type_Connect.HMA_M_def by auto
  have [transfer_rule]: "Mod_Type_Connect.HMA_M A' A"
    using A'_def unfolding Mod_Type_Connect.HMA_M_def by auto
  have "invertible P" using res_JNF by (transfer, simp)
  moreover have "invertible Q" using res_JNF by (transfer, simp)
  moreover have "isDiagonal S" using res_JNF by (transfer, simp)
  moreover have "S = P**A**Q" using res_JNF by (transfer, simp)
  ultimately show ?thesis by simp
qed
end

end

Theory SNF_Algorithm_Two_Steps

(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section ‹Smith normal form algorithm based on two steps in HOL Analysis›

theory SNF_Algorithm_Two_Steps
  imports Diagonalize
begin


text ‹This file contains an algorithm to transform a matrix to its Smith normal form, based 
on two steps: first it is converted into a diagonal matrix and then transformed from diagonal
to Smith.

We assume the existence of a diagonalize operation, and then we just have to connect it to the 
existing algorithm (in HOL Analysis) to transform a diagonal matrix into its Smith normal form.
›

subsection ‹The implementation›

context diagonalize
begin

definition "Smith_normal_form_of A bezout = (
   let (P'',D,Q'') = diagonalize A bezout;
       (P',S,Q') = diagonal_to_Smith_PQ D bezout
   in (P'**P'',S,Q''**Q')
  )"

subsection ‹Soundness in HOL Analysis›

lemma Smith_normal_form_of_soundness:
  fixes A::"'a::{bezout_ring}^'cols::{mod_type}^'rows::{mod_type}" 
  assumes b: "is_bezout_ext bezout"
  assumes PSQ: "(P,S,Q) = Smith_normal_form_of A bezout"
  shows "S = P**A**Q  invertible P  invertible Q  Smith_normal_form S"   
proof -
  obtain P'' D Q'' where PDQ_diag: "(P'',D,Q'') = diagonalize A bezout"
    by (metis prod_cases3)
  have 1: "invertible P''  invertible Q''  isDiagonal D  D = P''**A**Q''" 
    by (rule soundness_diagonalize[OF b PDQ_diag[symmetric]])
  obtain P' Q' where PSQ_D: "(P',S,Q') = diagonal_to_Smith_PQ D bezout"
    using PSQ PDQ_diag unfolding Smith_normal_form_of_def
    unfolding Let_def by (smt Pair_inject case_prod_beta' surjective_pairing)    
  have 2: "invertible P'  invertible Q'  Smith_normal_form S  S = P'**D**Q'"
    using diagonal_to_Smith_PQ' 1 b PSQ_D by blast
  have P: "P = P'**P''"
    by (metis (mono_tags, lifting) PDQ_diag PSQ_D Pair_inject 
        Smith_normal_form_of_def PSQ old.prod.case)
  have Q: "Q = Q''**Q'"
    by (metis (mono_tags, lifting) PDQ_diag PSQ_D Pair_inject 
        Smith_normal_form_of_def PSQ old.prod.case)
  have "S = P**A**Q" using 1 2 by (simp add: P Q matrix_mul_assoc)
  moreover have "invertible P" using P by (simp add: 1 2 invertible_mult)
  moreover have "invertible Q" using Q by (simp add: 1 2 invertible_mult)
  ultimately show ?thesis using 2 by auto
qed

end
end

Theory Diagonal_To_Smith_JNF

(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section ‹Algorithm to transform a diagonal matrix into its Smith normal form in JNF›

theory Diagonal_To_Smith_JNF
  imports Admits_SNF_From_Diagonal_Iff_Bezout_Ring
begin


text ‹In this file, we implement an algorithm to transform a diagonal matrix into its Smith
normal form, using the JNF library.

There are, at least, three possible options:
\begin{enumerate}
\item Implement and prove the soundness of the algorithm from scratch in JNF
\item Implement it in JNF and connect it to the HOL Analysis version by means of transfer rules.
Thus, we could obtain the soundness lemma in JNF.
\item Implement it in JNF, with calls to the HOL Analysis version by means of the functions 
@{text " from_hmam"} and @{text "to_hmam"}. That is, transform the matrix to HOL Analysis, apply
the existing algorith in HOL Analysis to get the Smith normal form and then transform the output 
to JNF. Then, we could try to get the soundness theorem in JNF by means of 
transfer rules and local type definitions.
\end{enumerate}

The first option requires much effort. As we will see, the third option is not possible.
›


subsection ‹Attempt with the third option: definitions and conditional transfer rules›

context
  fixes A::"'a::bezout_ring mat"
  assumes "A  carrier_mat CARD('nr::mod_type) CARD('nc::mod_type)"
begin

private definition "diagonal_to_Smith_PQ_JNF' bezout = (
  let A' = Mod_Type_Connect.to_hmam A::'a^'nc::mod_type^'nr::mod_type;
     (P,S,Q) = (diagonal_to_Smith_PQ A' bezout)
  in (Mod_Type_Connect.from_hmam P, Mod_Type_Connect.from_hmam S, Mod_Type_Connect.from_hmam Q))"

end

text ‹This approach will not work. The type is necessary in the definition of the function.
That is, outside the context, the function will be:

@{text "diagonal_to_Smith_PQ_JNF' TYPE('nc) TYPE('nr) A bezout"}

And we cannot get rid of such @{text "TYPE('nc)"}.

That is, we could get a lemma like:

@{theory_text "
lemma
  assumes A ∈ carrier_mat m n
  and (P,S,Q) = diagonal_to_Smith_PQ_JNF' TYPE('nr::mod_type) TYPE('nc::mod_type) A bezout
  shows invertible_mat P ∧ invertible_mat Q ∧ S = P * A * Q ∧ Smith_normal_form_mat S
"}

But we wouldn't be able to get rid of such types.
›

subsection ‹Attempt with the second option: implementation and soundness in JNF›


definition "diagonal_step_JNF A i j d v =               
              Matrix.mat (dim_row A) (dim_col A) (λ (a,b). if a = i  b = i then d else 
               if a = j  b = j 
               then v * (A $$ (j,j)) else A $$ (a,b))"

text ‹Conditional transfer rules are required, so I prove them within context with assumptions.›

context
  includes lifting_syntax
  fixes i and j::nat
  assumes i: "i<min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
  and j: "j<min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
begin
  
lemma HMA_diagonal_step[transfer_rule]: 
  "((Mod_Type_Connect.HMA_M :: _  'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type  _) 
    ===> (=) ===> (=) ===> Mod_Type_Connect.HMA_M) 
    (λA. diagonal_step_JNF A i j) (λB. diagonal_step B i j)" 
  by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def 
      diagonal_step_JNF_def diagonal_step_def)
 (rule eq_matI, auto simp add: Mod_Type_Connect.from_hmam_def, insert from_nat_eq_imp_eq i j, auto)

end

definition diagonal_step_PQ_JNF :: 
  "'a::{bezout_ring} mat  nat  nat  'a bezout  ('a mat × ('a mat))"
  where "diagonal_step_PQ_JNF A i k bezout = 
  (let  m = dim_row A; n = dim_col A;
        (p, q, u, v, d) = bezout (A $$ (i,i)) (A $$ (k,k));
        P = addrow (-v) k i (swaprows i k (addrow p k i (1m m)));
        Q = multcol k (-1) (addcol u k i (addcol q i k (1m n)))
        in (P,Q)
        )"

context
  includes lifting_syntax
  fixes i and k::nat
  assumes i: "i < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
  and k: "k < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
begin

lemma HMA_diagonal_step_PQ[transfer_rule]: 
  "((Mod_Type_Connect.HMA_M :: _  'a :: bezout_ring ^ 'nc :: mod_type ^ 'nr :: mod_type  _) 
    ===> (=) ===> rel_prod Mod_Type_Connect.HMA_M Mod_Type_Connect.HMA_M) 
    (λA bezout. diagonal_step_PQ_JNF A i k bezout) (λA bezout. diagonal_step_PQ A i k bezout)" 
proof (intro rel_funI, goal_cases)
  case (1 A A' bezout bezout')  
  note HMA_M_AA'[transfer_rule] = 1(1)
  let ?d_JNF = "(diagonal_step_PQ_JNF A i k bezout)"
  let ?d_HA = "(diagonal_step_PQ A' i k bezout)"
  have [transfer_rule]: "Mod_Type_Connect.HMA_I k (from_nat k::'nc)"
    and [transfer_rule]: "Mod_Type_Connect.HMA_I k (from_nat k::'nr)"
    by (metis Mod_Type_Connect.HMA_I_def k min.strict_boundedE to_nat_from_nat_id)+
  have [transfer_rule]: "Mod_Type_Connect.HMA_I i (from_nat i::'nc)"
    and [transfer_rule]: "Mod_Type_Connect.HMA_I i (from_nat i::'nr)"
      by (metis Mod_Type_Connect.HMA_I_def i min.strict_boundedE to_nat_from_nat_id)+
  have [transfer_rule]: "A $$ (i,i) = A' $h from_nat i $h from_nat i"
  proof -
    have "A $$ (i,i) = index_hma A' (from_nat i) (from_nat i)"  by (transfer, simp)
    also have "... = A' $h from_nat i $h from_nat i" unfolding index_hma_def by auto
    finally show ?thesis .
  qed
  have [transfer_rule]: "A $$ (k,k) = A' $h from_nat k $h from_nat k"
  proof -
    have "A $$ (k,k) = index_hma A' (from_nat k) (from_nat k)"  by (transfer, simp)
    also have "... = A' $h from_nat k $h from_nat k" unfolding index_hma_def by auto
    finally show ?thesis .
  qed
  have dim_row_CARD: "dim_row A = CARD('nr)"
    using HMA_M_AA' Mod_Type_Connect.dim_row_transfer_rule by blast
  have dim_col_CARD: "dim_col A = CARD('nc)"
    using HMA_M_AA' Mod_Type_Connect.dim_col_transfer_rule by blast  
  let ?p = "fst (bezout (A' $h from_nat i $h from_nat i) (A' $h from_nat k $h from_nat k))"
  let ?v = "fst (snd (snd (snd (bezout (A $$ (i, i)) (A $$ (k, k))))))"
  have "Mod_Type_Connect.HMA_M (fst ?d_JNF) (fst ?d_HA)" 
    unfolding diagonal_step_PQ_JNF_def diagonal_step_PQ_def Mod_Type_Connect.HMA_M_def    
    unfolding Let_def split_beta dim_row_CARD
    by (auto, transfer, auto simp add: Mod_Type_Connect.HMA_M_def Rel_def rel_funI)
  moreover have "Mod_Type_Connect.HMA_M (snd ?d_JNF) (snd ?d_HA)"
    unfolding diagonal_step_PQ_JNF_def diagonal_step_PQ_def Mod_Type_Connect.HMA_M_def    
    unfolding Let_def split_beta dim_col_CARD
    by (auto, transfer, auto simp add: Mod_Type_Connect.HMA_M_def Rel_def rel_funI)
  ultimately show ?case unfolding rel_prod_conv using 1
    by (simp add: split_beta)
qed

end


fun diagonal_to_Smith_i_PQ_JNF :: 
  "nat list  nat  ('a::{bezout_ring} bezout) 
   ('a mat × 'a mat × 'a mat)  ('a mat × 'a mat × 'a mat)"
 where
"diagonal_to_Smith_i_PQ_JNF [] i bezout (P,A,Q) = (P,A,Q)" |
"diagonal_to_Smith_i_PQ_JNF (j#xs) i bezout (P,A,Q) = (
  if A $$ (i,i) dvd A $$ (j,j) 
     then diagonal_to_Smith_i_PQ_JNF xs i bezout (P,A,Q)
  else let (p, q, u, v, d) = bezout (A $$ (i,i)) (A $$ (j,j)); 
           A' = diagonal_step_JNF A i j d v;
          (P',Q') = diagonal_step_PQ_JNF A i j bezout
      in diagonal_to_Smith_i_PQ_JNF xs i bezout (P'*P,A',Q*Q') ― ‹Apply the step›
  )
  "

context
  includes lifting_syntax
  fixes i and xs
  assumes i: "i < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
  and xs: "jset xs. j < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
begin

declare diagonal_step_PQ.simps[simp del]

lemma HMA_diagonal_to_Smith_i_PQ_aux: "HMA_M3 (P,A,Q)  
  (P' :: 'a :: bezout_ring ^ 'nr :: mod_type ^ 'nr :: mod_type,
   A' :: 'a :: bezout_ring ^ 'nc :: mod_type ^ 'nr :: mod_type,
   Q' :: 'a :: bezout_ring ^ 'nc :: mod_type ^ 'nc :: mod_type)
   HMA_M3 (diagonal_to_Smith_i_PQ_JNF xs i bezout (P,A,Q)) 
             (diagonal_to_Smith_i_PQ xs i bezout (P',A',Q'))"
  using i xs
proof (induct xs i bezout "(P',A',Q')" arbitrary: P' A' Q' P A Q rule: diagonal_to_Smith_i_PQ.induct)
  case (1 i bezout P' A' Q')
  then show ?case by auto
next
  case (2 j xs i bezout P' A' Q')
  note HMA_M3[transfer_rule] = "2.prems"(1)
  note i = 2(4)
  note j = 2(5)
  note IH1="2.hyps"(1)
  note IH2="2.hyps"(2)
  have j_min: "j < min CARD('nr) CARD('nc)" using j by auto
  have HMA_M_AA'[transfer_rule]: "Mod_Type_Connect.HMA_M A A'" using HMA_M3 by auto
  have [transfer_rule]: "Mod_Type_Connect.HMA_I j (from_nat j::'nc)"  
    and [transfer_rule]: "Mod_Type_Connect.HMA_I j (from_nat j::'nr)"
    by (metis Mod_Type_Connect.HMA_I_def j_min min.strict_boundedE to_nat_from_nat_id)+
  have [transfer_rule]: "Mod_Type_Connect.HMA_I i (from_nat i::'nc)"
    and [transfer_rule]: "Mod_Type_Connect.HMA_I i (from_nat i::'nr)"
      by (metis Mod_Type_Connect.HMA_I_def i min.strict_boundedE to_nat_from_nat_id)+
  have [transfer_rule]: "A $$ (i, i) = A' $h from_nat i $h from_nat i"
  proof -
    have "A $$ (i,i) = index_hma A' (from_nat i) (from_nat i)"  by (transfer, simp)
    also have "... = A' $h from_nat i $h from_nat i" unfolding index_hma_def by auto
    finally show ?thesis .
  qed
  have [transfer_rule]: "A $$ (j, j) = A' $h from_nat j $h from_nat j"
  proof -
    have "A $$ (j,j) = index_hma A' (from_nat j) (from_nat j)"  by (transfer, simp)
    also have "... = A' $h from_nat j $h from_nat j" unfolding index_hma_def by auto
    finally show ?thesis .
  qed
  show ?case
  proof (cases "A $$ (i, i) dvd A $$ (j, j)")
    case True
    hence "A' $h from_nat i $h from_nat i dvd A' $h from_nat j $h from_nat j" by transfer
    then show ?thesis using True IH1 HMA_M3 i j by auto
  next
    case False    
    obtain p q u v d where b: "(p, q, u, v, d) = bezout (A $$ (i,i)) (A $$ (j,j))"
      by (metis prod_cases5)
    let ?A'_JNF = "diagonal_step_JNF A i j d v"
    obtain P''_JNF Q''_JNF where P''Q''_JNF: "(P''_JNF,Q''_JNF) = diagonal_step_PQ_JNF A i j bezout"
      by (metis surjective_pairing)
    have not_dvd: "¬ A' $h from_nat i $h from_nat i dvd A' $h from_nat j $h from_nat j" using False by transfer
    let ?A' = "diagonal_step A' i j d v"
    obtain P'' Q'' where P''Q'': "(P'',Q'') = diagonal_step_PQ A' i j bezout" 
      by (metis surjective_pairing)
    have b2: "(p, q, u, v, d) = bezout (A' $h from_nat i $h from_nat i) (A' $h from_nat j $h from_nat j)" 
      using b by (transfer,auto)
    let ?D_HA = "diagonal_to_Smith_i_PQ xs i bezout (P''**P',?A',Q'**Q'')"
    let ?D_JNF = "diagonal_to_Smith_i_PQ_JNF xs i bezout (P''_JNF*P,?A'_JNF,Q*Q''_JNF)"
    have rw_1: "diagonal_to_Smith_i_PQ_JNF (j # xs) i bezout (P, A, Q) = ?D_JNF" 
      using False b P''Q''_JNF
      by (auto, unfold split_beta, metis fst_conv snd_conv)
    have rw_2: "diagonal_to_Smith_i_PQ (j # xs) i bezout (P', A', Q') = ?D_HA" 
      using not_dvd b2 P''Q'' by (auto, unfold split_beta, metis fst_conv snd_conv)
    have "HMA_M3 ?D_JNF ?D_HA" 
    proof (rule IH2[OF not_dvd b2], auto)
      have j: "j < min CARD('nr) CARD('nc)" using j by auto
      have [transfer_rule]: "rel_prod Mod_Type_Connect.HMA_M Mod_Type_Connect.HMA_M 
       (diagonal_step_PQ_JNF A i j bezout) (diagonal_step_PQ A' i j bezout)"
        using HMA_diagonal_step_PQ[OF i j] HMA_M_AA' unfolding rel_fun_def by auto
      hence [transfer_rule]: "Mod_Type_Connect.HMA_M P''_JNF P''" 
        and [transfer_rule]: "Mod_Type_Connect.HMA_M Q''_JNF Q''"
        using P''Q'' P''Q''_JNF unfolding rel_prod_conv split_beta
        by (metis fst_conv, metis snd_conv)
      have [transfer_rule]: "Mod_Type_Connect.HMA_M P P'" using HMA_M3 by auto
      show "Mod_Type_Connect.HMA_M (P''_JNF * P) (P'' ** P')" 
        (* apply (transfer, auto) does not finish the goal*)
        by (transfer_prover_start, transfer_step+, auto)      
     (* note HMA_diagonal_step[OF i j,transfer_rule]*)            
     (*transfer does not work for the following goal*)
      show "Mod_Type_Connect.HMA_M (diagonal_step_JNF A i j d v) (diagonal_step A' i j d v)"
        using HMA_diagonal_step[OF i j] HMA_M_AA' unfolding rel_fun_def by auto
      have [transfer_rule]: "Mod_Type_Connect.HMA_M Q Q'" using HMA_M3 by auto
      show "Mod_Type_Connect.HMA_M (Q * Q''_JNF) (Q' ** Q'')"
        by (transfer_prover_start, transfer_step+, auto)
    qed (insert i j P''Q'', auto)
    then show ?thesis using rw_1 rw_2 by auto
  qed
qed

lemma HMA_diagonal_to_Smith_i_PQ[transfer_rule]: 
  "((=) 
  ===> (HMA_M3 :: (_  (_×('a :: bezout_ring ^ 'nc :: mod_type ^ 'nr :: mod_type) × _) _)) 
  ===> HMA_M3) (diagonal_to_Smith_i_PQ_JNF xs i) (diagonal_to_Smith_i_PQ xs i)" 
proof (intro rel_funI, goal_cases)
  case (1 x y bezout bezout')
  then show ?case using HMA_diagonal_to_Smith_i_PQ_aux
    by (auto, smt HMA_M3.elims(2))
qed

end

fun Diagonal_to_Smith_row_i_PQ_JNF
  where "Diagonal_to_Smith_row_i_PQ_JNF i bezout (P,A,Q) 
  = diagonal_to_Smith_i_PQ_JNF [i + 1..<min (dim_row A) (dim_col A)] i bezout (P,A,Q)"

declare Diagonal_to_Smith_row_i_PQ_JNF.simps[simp del]
lemmas Diagonal_to_Smith_row_i_PQ_JNF_def = Diagonal_to_Smith_row_i_PQ_JNF.simps

context 
  includes lifting_syntax
  fixes i
  assumes i: "i < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
begin

lemma HMA_Diagonal_to_Smith_row_i_PQ[transfer_rule]:
  "((=) ===> (HMA_M3 :: (_  (_ × ('a::bezout_ring^'nc::mod_type^'nr::mod_type) × _)  _)) ===> HMA_M3) 
  (Diagonal_to_Smith_row_i_PQ_JNF i) (Diagonal_to_Smith_row_i_PQ i)"
proof (intro rel_funI, clarify, goal_cases)
  case (1 _ bezout P A Q P' A' Q')
  note HMA_M3[transfer_rule] = 1
  let ?xs1="[i + 1..<min (dim_row A) (dim_col A)]"
  let ?xs2="[i + 1..<min (nrows A') (ncols A')]"
  have xs_eq[transfer_rule]: "?xs1 = ?xs2"
    using HMA_M3
    by (auto intro: arg_cong2[where f = upt]
        simp: Mod_Type_Connect.dim_col_transfer_rule Mod_Type_Connect.dim_row_transfer_rule
        nrows_def ncols_def)
  have j_xs: "jset ?xs1. j < min CARD('nr) CARD('nc)" using i
    by (metis atLeastLessThan_iff ncols_def nrows_def set_upt xs_eq)
  have rel: "HMA_M3 (diagonal_to_Smith_i_PQ_JNF ?xs1 i bezout (P,A,Q)) 
            (diagonal_to_Smith_i_PQ ?xs1 i bezout (P',A',Q'))"
  using HMA_diagonal_to_Smith_i_PQ[OF i j_xs] HMA_M3 unfolding rel_fun_def by blast
  then show ?case 
    unfolding Diagonal_to_Smith_row_i_PQ_JNF_def Diagonal_to_Smith_row_i_PQ_def
    by (metis Suc_eq_plus1 xs_eq)
qed

end

fun diagonal_to_Smith_aux_PQ_JNF 
  where
  "diagonal_to_Smith_aux_PQ_JNF [] bezout (P,A,Q) = (P,A,Q)" |
  "diagonal_to_Smith_aux_PQ_JNF (i#xs) bezout (P,A,Q) 
      = diagonal_to_Smith_aux_PQ_JNF xs bezout (Diagonal_to_Smith_row_i_PQ_JNF i bezout (P,A,Q))"

context
  includes lifting_syntax
  fixes xs
  assumes xs: "jset xs. j < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
begin

lemma HMA_diagonal_to_Smith_aux_PQ_JNF[transfer_rule]:
  "((=) ===> (HMA_M3 :: (_  (_ × ('a::bezout_ring^'nc::mod_type^'nr::mod_type) × _)  _)) ===> HMA_M3) 
  (diagonal_to_Smith_aux_PQ_JNF xs) (diagonal_to_Smith_aux_PQ xs)"
proof (intro rel_funI, clarify, goal_cases)
  case (1 _ bezout P A Q P' A' Q')
  note HMA_M3[transfer_rule] = 1
  show ?case
    using xs HMA_M3
  proof (induct xs arbitrary: P' A' Q' P A Q)
    case Nil
    then show ?case by auto
  next
    case (Cons i xs)
    note IH = Cons(1)
    note HMA_M3 = Cons.prems(2)
    have i: "i < min CARD('nr) CARD('nc)" using Cons.prems by auto
    let ?D_JNF = "(Diagonal_to_Smith_row_i_PQ_JNF i bezout (P, A, Q))"
    let ?D_HA = "(Diagonal_to_Smith_row_i_PQ i bezout (P', A', Q'))"
    have rw_1: "diagonal_to_Smith_aux_PQ_JNF (i # xs) bezout (P, A, Q) 
        = diagonal_to_Smith_aux_PQ_JNF xs bezout ?D_JNF" by auto
    have rw_2: "diagonal_to_Smith_aux_PQ (i # xs) bezout (P', A', Q') 
        = diagonal_to_Smith_aux_PQ xs bezout ?D_HA" by auto
    have "HMA_M3 ?D_JNF ?D_HA" 
      using HMA_Diagonal_to_Smith_row_i_PQ[OF i] HMA_M3 unfolding rel_fun_def by blast
    then show ?case
      by (auto, smt Cons.hyps HMA_M3.elims(2) list.set_intros(2) local.Cons(2))
  qed
qed

end

fun diagonal_to_Smith_PQ_JNF
  where "diagonal_to_Smith_PQ_JNF A bezout 
  = diagonal_to_Smith_aux_PQ_JNF [0..<min (dim_row A) (dim_col A) - 1] 
    bezout (1m (dim_row A),A,1m (dim_col A))"


declare diagonal_to_Smith_PQ_JNF.simps[simp del]
lemmas diagonal_to_Smith_PQ_JNF_def = diagonal_to_Smith_PQ_JNF.simps

lemma diagonal_step_PQ_JNF_dim:
  assumes A: "A  carrier_mat m n"
    and d: "diagonal_step_PQ_JNF A i j bezout = (P,Q)"
  shows "P  carrier_mat m m  Q  carrier_mat n n"
  using A d unfolding diagonal_step_PQ_JNF_def split_beta Let_def by auto

lemma diagonal_step_JNF_dim:
  assumes A: "A  carrier_mat m n"
  shows "diagonal_step_JNF A i j d v  carrier_mat m n"
  using A unfolding diagonal_step_JNF_def by auto

lemma diagonal_to_Smith_i_PQ_JNF_dim:
  assumes "P'  carrier_mat m m  A'  carrier_mat m n  Q'  carrier_mat n n"
    and "diagonal_to_Smith_i_PQ_JNF xs i bezout (P',A',Q') = (P,A,Q)"
  shows "P  carrier_mat m m  A  carrier_mat m n  Q  carrier_mat n n"
  using assms 
  proof (induct xs i bezout "(P',A',Q')" arbitrary: P A Q P' A' Q' rule: diagonal_to_Smith_i_PQ_JNF.induct)
    case (1 i bezout P A Q)
    then show ?case by auto
  next
    case (2 j xs i bezout P' A' Q')
    show ?case
    proof (cases "A' $$ (i, i) dvd A' $$ (j, j)")
      case True
      then show ?thesis using 2 by auto
    next
      case False
      obtain p q u v d where b: "(p, q, u, v, d) = bezout (A' $$ (i,i)) (A' $$ (j,j))"
      by (metis prod_cases5)
      let ?A' = "diagonal_step_JNF A' i j d v"
      obtain P'' Q'' where P''Q'': "(P'',Q'') = diagonal_step_PQ_JNF A' i j bezout"
        by (metis surjective_pairing)
      let ?A' = "diagonal_step_JNF A' i j d v"
      let ?D_JNF = "diagonal_to_Smith_i_PQ_JNF xs i bezout (P''*P',?A',Q'*Q'')"
      have rw_1: "diagonal_to_Smith_i_PQ_JNF (j # xs) i bezout (P', A', Q') = ?D_JNF" 
        using False b P''Q''
        by (auto, unfold split_beta, metis fst_conv snd_conv)            
      show ?thesis 
      proof (rule "2.hyps"(2)[OF False b])
        show "?D_JNF = (P,A,Q)" using rw_1 2 by auto
        have "P''  carrier_mat m m" and "Q''  carrier_mat n n" 
          using diagonal_step_PQ_JNF_dim[OF _ P''Q''[symmetric]] "2.prems" by auto
        thus "P'' * P'  carrier_mat m m  ?A'  carrier_mat m n  Q' * Q''  carrier_mat n n" 
          using diagonal_step_JNF_dim 2 by (metis mult_carrier_mat)
    qed (insert P''Q'', auto)  
  qed  
qed

lemma Diagonal_to_Smith_row_i_PQ_JNF_dim:
  assumes "P'  carrier_mat m m  A'  carrier_mat m n  Q'  carrier_mat n n"
    and "Diagonal_to_Smith_row_i_PQ_JNF i bezout (P',A',Q') = (P,A,Q)"
  shows "P  carrier_mat m m  A  carrier_mat m n  Q  carrier_mat n n"
  by (rule diagonal_to_Smith_i_PQ_JNF_dim, insert assms, 
      auto simp add: Diagonal_to_Smith_row_i_PQ_JNF_def)  

lemma diagonal_to_Smith_aux_PQ_JNF_dim:
  assumes "P'  carrier_mat m m  A'  carrier_mat m n  Q'  carrier_mat n n"
    and "diagonal_to_Smith_aux_PQ_JNF xs bezout (P',A',Q') = (P,A,Q)"
  shows "P  carrier_mat m m  A  carrier_mat m n  Q  carrier_mat n n"
  using assms 
  proof (induct xs bezout "(P',A',Q')" arbitrary: P A Q P' A' Q' rule: diagonal_to_Smith_aux_PQ_JNF.induct)
    case (1 bezout P A Q)
    then show ?case by simp
  next
    case (2 i xs bezout P' A' Q')
    let ?D="(Diagonal_to_Smith_row_i_PQ_JNF i bezout (P', A', Q'))"
    have "diagonal_to_Smith_aux_PQ_JNF (i # xs) bezout (P', A', Q') = 
      diagonal_to_Smith_aux_PQ_JNF xs bezout ?D" by auto
    hence *: "... = (P,A,Q)" using 2 by auto
    let ?P="fst ?D"
    let ?S="fst (snd ?D)"
    let ?Q="snd (snd ?D)"
    show ?case
    proof (rule "2.hyps")      
      show "Diagonal_to_Smith_row_i_PQ_JNF i bezout (P', A', Q') = (?P,?S,?Q)" by auto
      show "diagonal_to_Smith_aux_PQ_JNF xs bezout (?P, ?S, ?Q) = (P, A, Q)" using * by simp
      show "?P  carrier_mat m m  ?S  carrier_mat m n  ?Q  carrier_mat n n" 
        by (rule Diagonal_to_Smith_row_i_PQ_JNF_dim, insert 2, auto)           
    qed
qed

lemma diagonal_to_Smith_PQ_JNF_dim:
  assumes "A  carrier_mat m n" 
    and PSQ: "diagonal_to_Smith_PQ_JNF A bezout = (P,S,Q)"
  shows "P  carrier_mat m m  S  carrier_mat m n  Q  carrier_mat n n"
  by (rule diagonal_to_Smith_aux_PQ_JNF_dim, insert assms, 
      auto simp add: diagonal_to_Smith_PQ_JNF_def)

context
  includes lifting_syntax
begin

lemma HMA_diagonal_to_Smith_PQ_JNF[transfer_rule]:
 "((Mod_Type_Connect.HMA_M) ===> (=) ===> HMA_M3) (diagonal_to_Smith_PQ_JNF) (diagonal_to_Smith_PQ)"
proof (intro rel_funI, clarify, goal_cases)
  case (1 A A' _ bezout)
  let ?xs1 = "[0..<min (dim_row A) (dim_col A) - 1]"
  let ?xs2 = "[0..<min (nrows A') (ncols A') - 1]"
  let ?PAQ="(1m (dim_row A), A, 1m (dim_col A))"
  have dr: "dim_row A = CARD('c)"
    using 1 Mod_Type_Connect.dim_row_transfer_rule by blast
  have dc: "dim_col A = CARD('b)" 
    using 1 Mod_Type_Connect.dim_col_transfer_rule by blast
  have xs_eq: "?xs1 = ?xs2"
    by (simp add: dc dr ncols_def nrows_def)
  have j_xs: "jset ?xs1. j < min CARD('c) CARD('b)"
    using dc dr less_imp_diff_less by auto
  let ?D_JNF = "diagonal_to_Smith_aux_PQ_JNF ?xs1 bezout ?PAQ"
  let ?D_HA = "diagonal_to_Smith_aux_PQ ?xs1 bezout (mat 1, A', mat 1)"
  have mat_rel_init: "HMA_M3 ?PAQ (mat 1, A', mat 1)"
  proof -    
    have "Mod_Type_Connect.HMA_M (1m (dim_row A)) (mat 1::'a^'c::mod_type^'c::mod_type)" 
      unfolding dr by (transfer_prover_start,transfer_step, auto)
    moreover have "Mod_Type_Connect.HMA_M (1m (dim_col A)) (mat 1::'a^'b::mod_type^'b::mod_type)"
      unfolding dc by (transfer_prover_start,transfer_step, auto)
    ultimately show ?thesis using 1 by auto
  qed
  have "HMA_M3 ?D_JNF ?D_HA"
    using HMA_diagonal_to_Smith_aux_PQ_JNF[OF j_xs] mat_rel_init unfolding rel_fun_def by blast
  then show ?case using xs_eq unfolding diagonal_to_Smith_PQ_JNF_def diagonal_to_Smith_PQ_def 
    by auto 
qed

end

subsection ‹Applying local type definitions›

text ‹Now we get the soundness lemma in JNF, via the one in HOL Analysis. I need transfer rules 
and local type definitions.›

context
  includes lifting_syntax
begin


private lemma diagonal_to_Smith_PQ_JNF_with_types:
  assumes A: "A  carrier_mat CARD('nr::mod_type) CARD('nc::mod_type)"
  and S: "S  carrier_mat CARD('nr) CARD('nc)"
  and P: "P  carrier_mat CARD('nr) CARD('nr)"
  and Q: "Q  carrier_mat CARD('nc) CARD('nc)"
  and PSQ: "diagonal_to_Smith_PQ_JNF A bezout = (P, S, Q)"
  and d:"isDiagonal_mat A" and ib: "is_bezout_ext bezout"
shows "S = P * A * Q  invertible_mat P  invertible_mat Q  Smith_normal_form_mat S"
proof -
  let ?P = "Mod_Type_Connect.to_hmam P::'a^'nr::mod_type^'nr::mod_type"
  let ?A = "Mod_Type_Connect.to_hmam A::'a^'nc::mod_type^'nr::mod_type"
  let ?Q = "Mod_Type_Connect.to_hmam Q::'a^'nc::mod_type^'nc::mod_type"
  let ?S = "Mod_Type_Connect.to_hmam S::'a^'nc::mod_type^'nr::mod_type"
  have [transfer_rule]: "Mod_Type_Connect.HMA_M A ?A"
    by (simp add: Mod_Type_Connect.HMA_M_def A)
  moreover have [transfer_rule]: "Mod_Type_Connect.HMA_M P ?P"
    by (simp add: Mod_Type_Connect.HMA_M_def P)  
  moreover have [transfer_rule]: "Mod_Type_Connect.HMA_M Q ?Q"
    by (simp add: Mod_Type_Connect.HMA_M_def Q)
  moreover have [transfer_rule]: "Mod_Type_Connect.HMA_M S ?S"
    by (simp add: Mod_Type_Connect.HMA_M_def S)
  ultimately have [transfer_rule]: "HMA_M3 (P,S,Q) (?P,?S,?Q)" by simp
  have [transfer_rule]: "bezout = bezout" ..
  have PSQ2: "(?P,?S,?Q) = diagonal_to_Smith_PQ ?A bezout" by (transfer, insert PSQ, auto)  
  have "?S = ?P**?A**?Q  invertible ?P  invertible ?Q  Smith_normal_form ?S"
    by (rule diagonal_to_Smith_PQ'[OF _ ib PSQ2], transfer, auto simp add: d)  
  with this[untransferred] show ?thesis by auto  
qed


private lemma diagonal_to_Smith_PQ_JNF_mod_ring_with_types:
  assumes A: "A  carrier_mat CARD('nr::nontriv mod_ring) CARD('nc::nontriv mod_ring)"
  and S: "S  carrier_mat CARD('nr mod_ring) CARD('nc mod_ring)"
  and P: "P  carrier_mat CARD('nr mod_ring) CARD('nr mod_ring)"
  and Q: "Q  carrier_mat CARD('nc mod_ring) CARD('nc mod_ring)"
  and PSQ: "diagonal_to_Smith_PQ_JNF A bezout = (P, S, Q)"
  and d:"isDiagonal_mat A" and ib: "is_bezout_ext bezout"
shows "S = P * A * Q  invertible_mat P  invertible_mat Q  Smith_normal_form_mat S"
  by (rule diagonal_to_Smith_PQ_JNF_with_types[OF assms])


(*I don't know how to internalize the sort constraint of 'nr and 'nc at once,
so I do it in two steps.*)
thm diagonal_to_Smith_PQ_JNF_mod_ring_with_types[unfolded CARD_mod_ring, 
      internalize_sort "'nr::nontriv"]

private lemma diagonal_to_Smith_PQ_JNF_internalized_first:
  "class.nontriv TYPE('a::type) 
  A  carrier_mat CARD('a) CARD('nc::nontriv) 
  S  carrier_mat CARD('a) CARD('nc) 
  P  carrier_mat CARD('a) CARD('a) 
  Q  carrier_mat CARD('nc) CARD('nc) 
  diagonal_to_Smith_PQ_JNF A bezout = (P, S, Q) 
  isDiagonal_mat A  is_bezout_ext bezout  
  S = P * A * Q  invertible_mat P  invertible_mat Q  Smith_normal_form_mat S"
  using diagonal_to_Smith_PQ_JNF_mod_ring_with_types[unfolded CARD_mod_ring, 
      internalize_sort "'nr::nontriv"] by blast


private lemma diagonal_to_Smith_PQ_JNF_internalized:
  "class.nontriv TYPE('c::type) 
  class.nontriv TYPE('a::type) 
  A  carrier_mat CARD('a) CARD('c) 
  S  carrier_mat CARD('a) CARD('c) 
  P  carrier_mat CARD('a) CARD('a) 
  Q  carrier_mat CARD('c) CARD('c) 
  diagonal_to_Smith_PQ_JNF A bezout = (P, S, Q) 
  isDiagonal_mat A  is_bezout_ext bezout  
S = P * A * Q  invertible_mat P  invertible_mat Q  Smith_normal_form_mat S"
  using diagonal_to_Smith_PQ_JNF_internalized_first[internalize_sort "'nc::nontriv"] by blast


context
  fixes m::nat and n::nat
  assumes local_typedef1: "(Rep :: ('b  int)) Abs. type_definition Rep Abs {0..<m :: int}"
  assumes local_typedef2: "(Rep :: ('c  int)) Abs. type_definition Rep Abs {0..<n :: int}"
  and m: "m>1"
  and n: "n>1"
begin

lemma type_to_set1:
  shows "class.nontriv TYPE('b)" (is ?a) and "m=CARD('b)" (is ?b)
proof -
  from local_typedef1 obtain Rep::"('b  int)" and Abs 
    where t: "type_definition Rep Abs {0..<m :: int}" by auto
  have "card (UNIV :: 'b set) = card {0..<m}" using t type_definition.card by fastforce
  also have "... = m" by auto
  finally show ?b ..
  then show ?a unfolding class.nontriv_def using m by auto
qed

lemma type_to_set2:
  shows "class.nontriv TYPE('c)" (is ?a) and "n=CARD('c)" (is ?b)
proof -
  from local_typedef2 obtain Rep::"('c  int)" and Abs 
    where t: "type_definition Rep Abs {0..<n :: int}" by blast
  have "card (UNIV :: 'c set) = card {0..<n}" using t type_definition.card by force
  also have "... = n" by auto
  finally show ?b ..
  then show ?a unfolding class.nontriv_def using n by auto
qed

lemma diagonal_to_Smith_PQ_JNF_local_typedef:  
  assumes A: "isDiagonal_mat A" and ib: "is_bezout_ext bezout"
  and A_dim: "A  carrier_mat m n"
  assumes PSQ: "(P,S,Q) = diagonal_to_Smith_PQ_JNF A bezout"
  shows "S = P*A*Q  invertible_mat P  invertible_mat Q  Smith_normal_form_mat S
   P  carrier_mat m m  S  carrier_mat m n  Q  carrier_mat n n"  
proof -  
  have dim_matrices: "P  carrier_mat m m  S  carrier_mat m n  Q  carrier_mat n n" 
    by (rule diagonal_to_Smith_PQ_JNF_dim[OF A_dim PSQ[symmetric]])
  show ?thesis
  using diagonal_to_Smith_PQ_JNF_internalized[where ?'c='c, where ?'a='b, 
      OF type_to_set2(1) type_to_set(1), of m A S P Q]  
  unfolding type_to_set1(2)[symmetric] type_to_set2(2)[symmetric] 
  using assms m dim_matrices local_typedef1 by auto
qed
end
end

(*Canceling the first local type definitions (I was not able to cancel both in one step)*)
context
begin
private lemma diagonal_to_Smith_PQ_JNF_canceled_first:
  "Rep Abs. type_definition Rep Abs {0..<int n}  {0..<int m}  {} 
  1 < m  1 < n  isDiagonal_mat A  is_bezout_ext bezout 
  A  carrier_mat m n  (P, S, Q) = diagonal_to_Smith_PQ_JNF A bezout 
  S = P * A * Q  invertible_mat P  invertible_mat Q  Smith_normal_form_mat S 
   P  carrier_mat m m  S  carrier_mat m n  Q  carrier_mat n n"
  using diagonal_to_Smith_PQ_JNF_local_typedef[cancel_type_definition] by blast

(*Canceling the second*)
private lemma diagonal_to_Smith_PQ_JNF_canceled_both:
  "{0..<int n}  {}  {0..<int m}  {}  1 < m  1 < n 
  isDiagonal_mat A  is_bezout_ext bezout  A  carrier_mat m n 
  (P, S, Q) = diagonal_to_Smith_PQ_JNF A bezout  S = P * A * Q 
  invertible_mat P  invertible_mat Q  Smith_normal_form_mat S 
   P  carrier_mat m m  S  carrier_mat m n  Q  carrier_mat n n"
  using diagonal_to_Smith_PQ_JNF_canceled_first[cancel_type_definition] by blast

subsection ‹The final result›

lemma diagonal_to_Smith_PQ_JNF:  
  assumes A: "isDiagonal_mat A" and ib: "is_bezout_ext bezout"
  and "A  carrier_mat m n" 
  and PBQ: "(P,S,Q) = diagonal_to_Smith_PQ_JNF A bezout" 
(*The following two assumptions appear since mod_type requires 1<CARD. 
Those cases could be treated separately.*)
  and n: "n>1" and m: "m>1" 
  shows "S = P*A*Q  invertible_mat P  invertible_mat Q  Smith_normal_form_mat S
   P  carrier_mat m m  S  carrier_mat m n  Q  carrier_mat n n"   
  using diagonal_to_Smith_PQ_JNF_canceled_both[OF _ _ m n] using assms by force
end
end

Theory SNF_Algorithm_Two_Steps_JNF

(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section ‹Smith normal form algorithm based on two steps in JNF›

theory SNF_Algorithm_Two_Steps_JNF
  imports   
  Diagonalize
  Diagonal_To_Smith_JNF
begin

subsection ‹Moving the result from HOL Analysis to JNF›
context diagonalize
begin

definition "Smith_normal_form_of_JNF A bezout = (
   let (P'',D,Q'') = diagonalize_JNF A bezout;
       (P',S,Q') = diagonal_to_Smith_PQ_JNF D bezout
   in (P'*P'',S,Q''*Q')
  )"

(*Soundness theorem in the JNF library*)

lemma Smith_normal_form_of_JNF_soundness:
  assumes b: "is_bezout_ext bezout" and A: "A  carrier_mat m n"
  and n: "1 < n" and m: "1 < m" (*Same as previously, those assumptions arose from the requirements 
of mod_type. They could be dropped proving them as particular cases*)
  and PSQ: "Smith_normal_form_of_JNF A bezout = (P,S,Q)"
shows "S = P*A*Q  invertible_mat P  invertible_mat Q  Smith_normal_form_mat S
   P  carrier_mat m m  S  carrier_mat m n  Q carrier_mat n n"   
proof -
  obtain P'' D Q'' where PDQ_diag: "(P'',D,Q'') = diagonalize_JNF A bezout"
    by (metis prod_cases3)
  have 1: "invertible_mat P''  invertible_mat Q''  isDiagonal_mat D  D = P''*A*Q''
       P''  carrier_mat m m  Q''  carrier_mat n n  D  carrier_mat m n"
    using soundness_diagonalize_JNF'[OF b A PDQ_diag[symmetric]] by auto    
  obtain P' Q' where PSQ_D: "(P',S,Q') = diagonal_to_Smith_PQ_JNF D bezout"
    using PSQ PDQ_diag unfolding Smith_normal_form_of_JNF_def Let_def split_beta
    by (metis Pair_inject prod.collapse)
  have 2: "invertible_mat P'  invertible_mat Q'  Smith_normal_form_mat S  S = P'*D*Q'
     P'  carrier_mat m m  Q'  carrier_mat n n  S  carrier_mat m n"
    using diagonal_to_Smith_PQ_JNF[OF _ b _ PSQ_D n m] 1 n m by auto
  have P: "P = P'*P''"
    by (metis (no_types, lifting) PDQ_diag PSQ PSQ_D Smith_normal_form_of_JNF_def fst_conv prod.simps(2))    
  have Q: "Q = Q''*Q'"
    by (metis (no_types, lifting) PDQ_diag PSQ PSQ_D Smith_normal_form_of_JNF_def snd_conv prod.simps(2))
  have "S = P'*(P''*A*Q'')*Q'" using 1 2 by auto
  also have "... = (P'*P'')*A*(Q''*Q')" 
    by (smt "1" "2" A assoc_mult_mat carrier_matD carrier_mat_triv index_mult_mat)
  finally have "S = (P' * P'') * A * (Q'' * Q')" .
  moreover have "invertible_mat P" unfolding P by (rule invertible_mult_JNF, insert 1 2, auto)
  moreover have "invertible_mat Q" unfolding Q by (rule invertible_mult_JNF, insert 1 2, auto)
  ultimately show ?thesis using 1 2 P Q by auto
qed

end
end

Theory SNF_Algorithm

(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section ‹A general algorithm to transform a matrix into its Smith normal form›

theory SNF_Algorithm
  imports    
    Smith_Normal_Form_JNF
begin

text ‹This theory presents an executable algorithm to transform a matrix
to its Smith normal form.›

subsection ‹Previous definitions and lemmas›

definition "is_SNF A R = (case R of (P,S,Q)  
  P  carrier_mat (dim_row A) (dim_row A) 
  Q  carrier_mat (dim_col A) (dim_col A) 
   invertible_mat P  invertible_mat Q 
   Smith_normal_form_mat S  S = P * A * Q)"


lemma is_SNF_intro: 
  assumes "P  carrier_mat (dim_row A) (dim_row A)"
  and "Q  carrier_mat (dim_col A) (dim_col A) "
  and "invertible_mat P" and "invertible_mat Q" 
  and "Smith_normal_form_mat S" and "S = P * A * Q"
shows "is_SNF A (P,S,Q)" using assms unfolding is_SNF_def by auto


(*With the following lemmas, we show that for the case 1xn only column operations are needed
  and the algorithm just needs to return two matrices.*)

lemma Smith_1xn_two_matrices:
  fixes A :: "'a::comm_ring_1 mat"
  assumes A: "A  carrier_mat 1 n" 
  and PSQ: "(P,S,Q) = (Smith_1xn A)"
  and is_SNF: "is_SNF A (Smith_1xn A)"
shows "Smith_1xn'. is_SNF A (1m 1, (Smith_1xn' A))"
proof -
  let ?Q = "P$$(0,0) m Q"
  have P00_dvd_1: "P $$ (0, 0) dvd 1"
    by (metis (mono_tags, lifting) assms carrier_matD(1) determinant_one_element 
        invertible_iff_is_unit_JNF is_SNF_def prod.simps(2))
  have "is_SNF A (1m 1,S,?Q)"
  proof (rule is_SNF_intro)
    show "invertible_mat (P $$ (0, 0) m Q)"
      by (rule invertible_mat_smult_mat, insert P00_dvd_1 assms, auto simp add: is_SNF_def)
    show "S = 1m 1 * A * (P $$ (0, 0) m Q)" 
      by (smt A PSQ is_SNF carrier_matD(2) index_mult_mat(2) index_one_mat(2) left_mult_one_mat
          mult_smult_assoc_mat mult_smult_distrib smult_mat_mat_one_element is_SNF_def split_conv)      
  qed (insert assms, auto simp add: is_SNF_def)
  thus ?thesis by auto
qed

lemma Smith_1xn_two_matrices_all:
  assumes is_SNF: "(A::'a::comm_ring_1 mat)  carrier_mat 1 n. is_SNF A (Smith_1xn A)"
  shows "Smith_1xn'. (A::'a::comm_ring_1 mat)  carrier_mat 1 n. is_SNF A (1m 1, (Smith_1xn' A))"
proof -
  let ?Smith_1xn' = "λA. let (P,S,Q) = (Smith_1xn A) in (S, P $$ (0, 0) m Q)"
  show ?thesis by (rule exI[of _ ?Smith_1xn']) (smt Smith_1xn_two_matrices assms carrier_matD 
        carrier_matI case_prodE determinant_one_element index_smult_mat(2,3) invertible_iff_is_unit_JNF
        invertible_mat_smult_mat smult_mat_mat_one_element left_mult_one_mat is_SNF_def 
        mult_smult_assoc_mat mult_smult_distrib prod.simps(2))
qed

subsection ‹Previous operations›
(*Reduce column, parameterized by a div operation*)
context 
assumes "SORT_CONSTRAINT('a::comm_ring_1)"
begin

definition is_div_op :: "('a'a'a) bool"
  where "is_div_op div_op = (a b. b dvd a  div_op a b * b = a)"

(* With SOME, we can get a (non-executable) div operation:*)
lemma div_op_SOME: "is_div_op (λa b. (SOME k. k * b = a))"
proof (unfold is_div_op_def, rule+)
  fix a b::'a assume dvd: "b dvd a" 
  show "(SOME k. k * b = a) * b = a" by (rule someI_ex, insert dvd dvd_def) (metis dvdE mult.commute)
qed

fun reduce_column_aux :: "('a'a'a)  nat list  'a mat  ('a mat × 'a mat)  ('a mat × 'a mat)"
  where "reduce_column_aux div_op [] H (P,K) = (P,K)" 
  | "reduce_column_aux div_op (i#xs) H (P,K) = (
    ― ‹Reduce the i-th row›
    let k = div_op (H$$(i,0)) (H $$ (0, 0));
        P' = addrow_mat (dim_row H) (-k) i 0;
        K' = addrow (-k) i 0 K
  in reduce_column_aux div_op xs H (P'*P,K')    
  )"

definition "reduce_column div_op H = reduce_column_aux div_op [2..<dim_row H] H (1m (dim_row H),H)"


lemma reduce_column_aux:
  assumes H: "H  carrier_mat m n" 
    and P_init: "P_init  carrier_mat m m"
    and K_init: "K_init  carrier_mat m n"
  and P_init_H_K_init: "P_init * H = K_init"
  and PK_H: "(P,K) = reduce_column_aux div_op xs H (P_init,K_init)"
  and m: "0 < m"
  and inv_P: "invertible_mat P_init"
  and xs: "0  set xs"
shows "P  carrier_mat m m  K  carrier_mat m n  P * H = K  invertible_mat P"
  using assms
  unfolding reduce_column_def
proof (induct div_op xs H "(P_init,K_init)" arbitrary: P_init K_init rule: reduce_column_aux.induct)
  case (1 div_op H P K)
  then show ?case by simp
next
  case (2 div_op i xs H P_init K_init)  
  show ?case
  proof (rule "2.hyps")
      let ?x = "div_op (H $$ (i, 0)) (H $$ (0, 0))"
      let ?xa = "addrow_mat (dim_row H) (- ?x) i 0"
      let ?xb = "addrow (- ?x) i 0 K_init"
      show "(P, K) = reduce_column_aux div_op xs H (?xa * P_init, ?xb)" 
        using "2.prems" by (auto simp add: Let_def)
      show "?xa * P_init  carrier_mat m m" using "2"(2) "2"(3) by auto
      show "0  set xs" using "2.prems" by auto
      have "?xa * K_init = ?xb" 
        by (rule addrow_mat[symmetric], insert "2.prems", auto)                  
      thus "?xa * P_init * H = ?xb"
        by (metis (no_types, lifting) "2"(5) "2.prems"(1) "2.prems"(2) addrow_mat_carrier 
            assoc_mult_mat carrier_matD(1))
      show "invertible_mat (?xa * P_init)" 
      proof (rule invertible_mult_JNF)
        show xa: "?xa  carrier_mat m m" using "2"(2) by auto        
        have "Determinant.det ?xa = 1" by (rule det_addrow_mat, insert "2.prems", auto)
        thus "invertible_mat ?xa" unfolding invertible_iff_is_unit_JNF[OF xa] by simp     
      qed (auto simp add: "2.prems")
    qed(auto simp add: "2.prems")
  qed


lemma reduce_column_aux_preserves:
  assumes H: "H  carrier_mat m n" 
    and P_init: "P_init  carrier_mat m m"
    and K_init: "K_init  carrier_mat m n"
  and P_init_H_K_init: "P_init * H = K_init"
  and PK_H: "(P,K) = reduce_column_aux div_op xs H (P_init,K_init)"
  and m: "0 < m"
  and inv_P: "invertible_mat P_init"
  and xs: "0  set xs"  and i: "i  set xs" and im: "i<m"
shows "Matrix.row K i = Matrix.row K_init i"
  using PK_H inv_P H P_init K_init m xs i
  unfolding reduce_column_def
proof (induct div_op xs H "(P_init,K_init)" arbitrary: P_init K_init K rule: reduce_column_aux.induct)
  case (1 div_op H P K)
  then show ?case by auto
next
  case (2 div_op x xs H P_init K_init)
  thm "2.prems"
  "2.hyps"
      let ?x = "div_op (H $$ (x, 0)) (H $$ (0, 0))"
      let ?xa = "addrow_mat (dim_row H) (- ?x) x 0"
      let ?xb = "addrow (- ?x) x 0 K_init"
      have IH: "Matrix.row K i = Matrix.row ?xb i"
      proof (rule "2.hyps")
        show "(P, K) = reduce_column_aux div_op xs H (?xa * P_init, ?xb)" 
          using "2.prems" by (auto simp add: Let_def)
        show "?xa * P_init  carrier_mat m m"
          using "2"(4) "2"(5) by auto    
        have "?xa * K_init = ?xb" 
          by (rule addrow_mat[symmetric], insert "2.prems", auto)
        show "invertible_mat (?xa * P_init)" 
        proof (rule invertible_mult_JNF)
          show xa: "?xa  carrier_mat m m" using "2.prems" by auto        
          have "Determinant.det ?xa = 1" by (rule det_addrow_mat, insert "2.prems", auto)
          thus "invertible_mat ?xa" unfolding invertible_iff_is_unit_JNF[OF xa] by simp     
        qed (auto simp add: "2.prems")
        show "i  set xs" using "2"(9) by auto
        show "0  set xs" using "2"(8) by auto
      qed(auto simp add: "2.prems")
      also have "... = Matrix.row K_init i"
        by (rule eq_vecI, auto, insert "2" "2.prems" im, auto)    
      finally show ?case .    
qed

lemma reduce_column_aux_index':
  assumes H: "H  carrier_mat m n" 
    and P_init: "P_init  carrier_mat m m"
    and K_init: "K_init  carrier_mat m n"
  and P_init_H_K_init: "P_init * H = K_init"
  and PK_H: "(P,K) = reduce_column_aux div_op xs H (P_init,K_init)"
  and m: "0 < m"
  and inv_P: "invertible_mat P_init"
  and xs: "0  set xs"  
  and "xset xs. x<m"
  and "distinct xs"
shows "(iset xs. Matrix.row K i = 
    Matrix.row (addrow (-(div_op (H $$ (i, 0)) (H $$ (0, 0)))) i 0 K_init) i)"
  using assms
  unfolding reduce_column_def
proof (induct div_op xs H "(P_init,K_init)" arbitrary: P_init K_init K rule: reduce_column_aux.induct)
  case (1 div_op H P K)
  then show ?case by simp
next
  case (2 div_op i xs H P_init K_init)
  let ?x = "div_op (H $$ (i, 0)) (H $$ (0, 0)) "
  let ?xa = "addrow_mat (dim_row H) ?x i 0"
  thm "2.prems"
  thm "2.hyps"
  let ?xb = "addrow (- ?x) i 0 K_init"
  let ?xa = "addrow_mat (dim_row H) (- ?x) i 0"
  have "reduce_column_aux div_op (i#xs) H (P_init,K_init) 
    = reduce_column_aux div_op xs H (?xa*P_init,?xb)"
    by (auto simp add: Let_def)
  hence PK: "(P,K) = reduce_column_aux div_op xs H (?xa*P_init,?xb)" using "2.prems" by simp
      have xa_P_init:  "?xa * P_init  carrier_mat m m" using "2"(2) "2"(3) by auto
      have zero_notin_xs: "0  set xs" using "2.prems" by auto
      have "?xa * K_init = ?xb" 
        by (rule addrow_mat[symmetric], insert "2.prems", auto)                  
      hence rw: "?xa * P_init * H = ?xb"
        by (metis (no_types, lifting) "2"(5) "2.prems"(1) "2.prems"(2) addrow_mat_carrier 
            assoc_mult_mat carrier_matD(1))
      have inv_xa_P_init: "invertible_mat (?xa * P_init)" 
      proof (rule invertible_mult_JNF)
        show xa: "?xa  carrier_mat m m" using "2"(2) by auto        
        have "Determinant.det ?xa = 1" by (rule det_addrow_mat, insert "2.prems", auto)
        thus "invertible_mat ?xa" unfolding invertible_iff_is_unit_JNF[OF xa] by simp     
      qed (auto simp add: "2.prems")
      have i1: "i0" using "2.prems"(8) by auto
      have i2: "i<m" by (simp add: "2.prems"(9))
      have i3: "iset xs" using 2 by auto
      have d: "distinct xs" using 2 by auto
      have "iset xs. Matrix.row K i = Matrix.row (addrow (- (div_op (H $$ (i, 0)) (H $$ (0, 0)))) 
            i 0 ?xb) i"
    by (rule "2.hyps", insert xa_P_init zero_notin_xs rw inv_xa_P_init d, 
        auto simp add: "2.prems" Let_def)  
  moreover have "Matrix.row (addrow (- (div_op (H $$ (j, 0)) (H $$ (0, 0)))) j 0 ?xb) j 
  = Matrix.row (addrow (- (div_op (H $$ (j, 0)) (H $$ (0, 0)))) j 0 K_init) j" 
    (is "Matrix.row ?lhs j= Matrix.row ?rhs j")
    if j: "j  set xs" for j 
  proof (rule eq_vecI)
    fix ia assume ia: "ia<dim_vec(Matrix.row ?rhs j)"
    let ?k = "div_op (H $$ (j, 0)) (H $$ (0, 0))"
    let ?L = "(addrow (- (div_op (H $$ (i, 0)) (H $$ (0, 0)))) i 0 K_init)"
    have "Matrix.row ?lhs j $v ia = ?lhs $$ (j,ia)"
      by (metis (no_types, lifting) Matrix.row_def ia index_mat_addrow(5) index_row(2) index_vec)
    also have "... = (-?k) * ?L$$(0,ia) + ?L$$(j,ia)"      
      by (smt "2.prems"(1) "2.prems"(9) carrier_matD(1) ia index_mat_addrow(1,5) index_row(2) 
          insert_iff list.set(2) mult_carrier_mat rw that xa_P_init)
    also have "... = ?rhs $$ (j,ia)" using "2"(10) "2"(4) i1 i3 ia j by auto
    also have "... = Matrix.row ?rhs j $v ia" using 2 ia j by auto
    finally show "Matrix.row ?lhs j $v ia = Matrix.row ?rhs j $v ia" .
  qed (auto)
  ultimately have "jset xs. Matrix.row K j = 
    Matrix.row (addrow (- (div_op (H $$ (j, 0)) (H $$ (0, 0)))) j 0 K_init) j" by auto
  moreover have "Matrix.row K i = Matrix.row ?xb i" 
     by (rule reduce_column_aux_preserves[OF _ xa_P_init _ rw PK _ inv_xa_P_init zero_notin_xs 
            i3 i2],insert "2.prems", auto)
   ultimately show ?case by auto
 qed

corollary reduce_column_aux_index:
  assumes H: "H  carrier_mat m n" 
    and P_init: "P_init  carrier_mat m m"
    and K_init: "K_init  carrier_mat m n"
  and P_init_H_K_init: "P_init * H = K_init"
  and PK_H: "(P,K) = reduce_column_aux div_op xs H (P_init,K_init)"
  and m: "0 < m"
  and inv_P: "invertible_mat P_init"
  and xs: "0  set xs"  
  and "xset xs. x<m"
  and "distinct xs"
  and "iset xs"
shows "Matrix.row K i = 
    Matrix.row (addrow (-(div_op (H $$ (i, 0)) (H $$ (0, 0)))) i 0 K_init) i"
  using reduce_column_aux_index' assms by simp


corollary reduce_column_aux_works:
  assumes H: "H  carrier_mat m n"           
  and PK_H: "(P,K) = reduce_column_aux div_op xs H (1m (dim_row H), H)"
  and m: "0 < m"
  and xs: "0  set xs"  
  and xm: "x  set xs. x<m"
  and d_xs: "distinct xs"
  and i: "i  set xs"
  and dvd: "H $$ (0, 0) dvd H $$ (i, 0)"
  and j0: "j{1..<n}. H$$(0,j) = 0"
  and j1n: "j{1..<n}"
  and n: "0<n"
  and id: "is_div_op div_op"
shows "K $$ (i,0) = 0" and "K$$(i,j) = H $$ (i,j)" 
proof -
  let ?k = "div_op (H $$ (i, 0)) (H $$ (0, 0))"
  let ?L = "addrow (-?k) i 0 H"
  have kH00_eq_Hi0: "?k * H $$ (0, 0) = H $$ (i, 0)" 
    using id dvd unfolding is_div_op_def by simp
  have *: "Matrix.row K i = Matrix.row ?L i"
    by (rule reduce_column_aux_index[OF H _ _ _ PK_H], insert assms, auto)
  also have " ... $v 0 = ?L $$ (i,0)" by (rule index_row, insert xm i H n, auto)
  also have "... = (- ?k) * H$$(0,0) + H$$(i,0)" by (rule index_mat_addrow, insert i xm H n, auto)
  also have "... = 0" using kH00_eq_Hi0 by auto
  finally show "K $$ (i, 0) = 0"
    by (metis H Matrix.row_def * n carrier_matD(2) dim_vec index_mat_addrow(5) index_vec)
  have "Matrix.row ?L i $v j = ?L $$ (i,j)" by (rule index_row, insert xm i H n j1n, auto)
  also have "... = (- ?k) * H$$(0,j) + H$$(i,j)" by (rule index_mat_addrow, insert xm i H j1n, auto)
  also have "... = H$$(i,j)" using j1n j0 by auto
  finally show "K$$(i,j) = H $$ (i,j)" by (metis H * Matrix.row_def atLeastLessThan_iff 
        carrier_matD(2) dim_vec index_mat_addrow(5) index_vec j1n)
qed

lemma reduce_column:
  assumes H: "H  carrier_mat m n"           
  and PK_H: "(P,K) = reduce_column div_op H"
  and m: "0 < m"
shows "P  carrier_mat m m  K  carrier_mat m n  P * H = K  invertible_mat P"
  by (rule reduce_column_aux[OF _ _ _ _ PK_H[unfolded reduce_column_def]], insert assms, auto)

lemma reduce_column_preserves:
  assumes H: "H  carrier_mat m n"           
  and PK_H: "(P,K) = reduce_column div_op H"
  and m: "0 < m"
  and "i{0,1}"
  and "i<m"
shows "Matrix.row K i = Matrix.row H i"
  by (rule reduce_column_aux_preserves[OF _ _ _ _ PK_H[unfolded reduce_column_def]], 
      insert assms, auto)

lemma reduce_column_preserves2:
  assumes H: "H  carrier_mat m n"           
  and PK_H: "(P,K) = reduce_column div_op H"
  and m: "0 < m" and i: "i{0,1}" and im: "i<m" and j: "j<n"
shows "K $$ (i,j) = H $$ (i,j)"
  using reduce_column_preserves[OF H PK_H m i im]
  by (metis H Matrix.row_def j carrier_matD(2) dim_vec index_vec)
  

corollary reduce_column_works:
  assumes H: "H  carrier_mat m n"           
  and PK_H: "(P,K) = reduce_column div_op H"
  and m: "0 < m"
  and dvd: "H $$ (0, 0) dvd H $$ (i, 0)"
  and j0: "j{1..<n}. H $$ (0, j) = 0"
  and j1n: "j{1..<n}"
  and n: "0<n"
  and "i{2..<m}"
  and id: "is_div_op div_op"
shows "K $$ (i,0) = 0" and "K$$(i,j) = H $$ (i,j)" 
    by (rule reduce_column_aux_works[OF H PK_H[unfolded reduce_column_def]], insert assms, auto)+

end


subsection ‹The implementation›

text ‹We define a locale where we implement the algorithm. It has three fixed operations:
\begin{enumerate}
\item an operation to transform any $1 \times 2$ matrix into its Smith normal form
\item an operation to transform any $2 \times 2$ matrix into its Smith normal form
\item an operation that provides a witness for division (this operation always exists over a 
      commutative ring with unit, but maybe we cannot provide a computable algorithm).
\end{enumerate}

Since we are working in a commutative ring, we can easily get an operation for $2 \times 1$ matrices
via the $1 \times 2$ operation.
›
locale Smith_Impl =   
  fixes Smith_1x2 :: "('a::comm_ring_1) mat  ('a mat × 'a mat)"
    and Smith_2x2 :: "'a mat  ('a mat × 'a mat × 'a mat)"
    and div_op :: "'a'a'a"
  assumes SNF_1x2_works: "(A::'a mat)  carrier_mat 1 2. is_SNF A (1m 1, (Smith_1x2 A))" 
    and SNF_2x2_works: "(A::'a mat)  carrier_mat 2 2. is_SNF A (Smith_2x2 A)"
    and id: "is_div_op div_op"
begin

text ‹From a $2 \times 2$ matrix (the $B$), we construct the identity matrix of size $n$ with 
the elements of $B$ placed to modify the first element of a matrix and the element in position 
$(k,k)$›

definition "make_mat n k (B::'a mat) = (Matrix.mat n n (λ(i,j). if i = 0  j = 0 then B$$(0,0) else
    if i = 0  j = k then B$$(0,1) else if i=k  j = 0 
      then B$$(1,0) else if i=k  j=k then B$$(1,1) 
      else if i=j then 1 else 0))"

lemma make_mat_carrier[simp]:
  shows "make_mat n k B  carrier_mat n n"
  unfolding make_mat_def by auto

lemma upper_triangular_mat_delete_make_mat:
  shows "upper_triangular (mat_delete (make_mat n k B) 0 0)"
proof -
  {  let ?M = "make_mat n k B"
  fix i j
  assume "i < dim_row ?M - Suc 0" and ji: "j < i"
  hence i_n1: "i < n - 1" by (simp add: make_mat_def)
  hence Suc_i: "Suc i < n" by linarith
  hence Suc_j: "Suc j < n" using ji by auto
  have i1: "insert_index 0 i = Suc i" by (rule insert_index, auto)
  have j1: "insert_index 0 j = Suc j" by (rule insert_index, auto)
  have "mat_delete ?M 0 0 $$ (i, j) = ?M $$ (insert_index 0 i, insert_index 0 j)"
    by (rule mat_delete_index[symmetric, OF _ _ _ i_n1], insert Suc_i Suc_j, auto)   
  also have "... = ?M $$ (Suc i, Suc j)" unfolding i1 j1 by simp
  also have "... = 0" unfolding make_mat_def unfolding index_mat[OF Suc_i Suc_j] using ji by auto
  finally have "mat_delete ?M 0 0 $$ (i, j) = 0" .
  }
  thus ?thesis  unfolding upper_triangular_def by auto
qed

lemma upper_triangular_mat_delete_make_mat2:
  assumes kn: "k<n"
  shows "upper_triangular (mat_delete (mat_delete (make_mat n k B) 0 k) (k - 1) 0)"
proof -
  {  let ?M = "local.make_mat n k B"
  let ?MD = "mat_delete ?M 0 k"
  fix i j assume i: "i < dim_row ?M - 2" and ji: "j < i"  
  have insert_in: "insert_index 0 i < n" and insert_Sucin: "insert_index 0 (Suc i) < n"
    using i make_mat_def by auto
  have insert_k_Sucj: "insert_index k (Suc j) < n"
    using insert_in insert_index_def ji by auto
  have insert_j: "insert_index 0 j = Suc j" by simp  
  have "mat_delete ?MD (k - 1) 0 $$ (i, j) = ?MD $$ (insert_index (k-1) i, insert_index 0 j)" 
  proof (rule mat_delete_index[symmetric])
    show "i < n-2" using i by (simp add: make_mat_def)  
    thus "?MD  carrier_mat (Suc (n - 2)) (Suc (n - 2))"
      by (metis Suc_diff_Suc card_num_simps(30) make_mat_carrier mat_delete_carrier 
          nat_diff_split_asm not_less0 not_less_eq numerals(2))
    show "k - 1 < Suc (n - 2)" using kn by auto  
    show "0 < Suc (n - 2)" by blast
    show "j < n - 2" using ji i by (simp add: make_mat_def)  
  qed
  also have "... = ?MD $$ (insert_index (k-1) i, Suc j)" unfolding insert_j by auto
  also have "... = 0"
  proof (cases "i < (k-1)")
    case True
    hence "insert_index (k-1) i = i" by auto
    hence "?MD $$ (insert_index (k-1) i, Suc j) = ?MD $$ (i, Suc j)" by auto
    also have "... = ?M $$ (insert_index 0 i, insert_index k (Suc j))" 
    proof (rule mat_delete_index[symmetric])
      show "?M  carrier_mat (Suc (n-1)) (Suc (n-1))" using assms by auto
      show "0 < Suc (n - 1)" 
        by blast
      show "k < Suc (n - 1)"using kn by simp
      show "i < n - 1" using i using True assms by linarith
      thus "Suc j < n - 1" using ji less_trans_Suc by blast
    qed
    also have "... = 0" unfolding make_mat_def index_mat[OF insert_in insert_k_Sucj]
      using True ji by auto
    finally show ?thesis .
    next
      case False
      hence "insert_index (k-1) i = Suc i" by auto
      hence "?MD $$ (insert_index (k-1) i, Suc j) = ?MD $$ (Suc i, Suc j)" by auto
    also have "... = ?M $$ (insert_index 0 (Suc i), insert_index k (Suc j))" 
    proof (rule mat_delete_index[symmetric])
      show "?M  carrier_mat (Suc (n-1)) (Suc (n-1))" using assms by auto
      thus "Suc i < n - 1" using i using False assms
        by (metis One_nat_def Suc_diff_Suc carrier_matD(1) diff_Suc_1 diff_Suc_eq_diff_pred 
            diff_is_0_eq' linorder_not_less nat.distinct(1) numeral_2_eq_2)
      show "0 < Suc (n - 1)" 
        by blast
      show "k < Suc (n - 1)"using kn by simp
      show "Suc j < n - 1" using ji less_trans_Suc
        using ‹Suc i < n - 1 by linarith
    qed
    also have "... = 0" unfolding make_mat_def index_mat[OF insert_Sucin insert_k_Sucj]
      using False ji by (auto, smt insert_index_def less_SucI nat.inject nat_neq_iff)
    finally show ?thesis .    
  qed  
  finally have "mat_delete ?MD (k - 1) 0 $$ (i, j) = 0" .
}
  thus ?thesis unfolding upper_triangular_def by auto
qed

corollary det_mat_delete_make_mat:
  assumes kn: "k<n"
  shows "Determinant.det (mat_delete (mat_delete (make_mat n k B) 0 k) (k - 1) 0) = 1"
proof -
  let ?M = "make_mat n k B"
  let ?MD = "mat_delete ?M 0 k"
  let ?MDMD = "mat_delete ?MD (k - 1) 0"
  have eq1: "?MDMD $$ (i,i) = 1" if i: "i<n-2" for i
  proof -
    have i1: "insert_index 0 (insert_index (k-1) i) < n" using i insert_index_def by auto
    have i2: "insert_index k (insert_index 0 i) < n" using i insert_index_def by auto
    have "?MDMD $$ (i, i) = ?MD $$ (insert_index (k-1) i, insert_index 0 i)"
    proof (rule mat_delete_index[symmetric, OF _ _ _ i i])
      show "mat_delete (local.make_mat n k B) 0 k  carrier_mat (Suc (n-2)) (Suc (n-2))"
        by (metis (mono_tags, hide_lams) Suc_diff_Suc card_num_simps(30) i make_mat_carrier 
            mat_delete_carrier nat_diff_split_asm not_less0 not_less_eq numerals(2))    
      show "k - 1 < Suc (n - 2)" using kn by auto
      show "0 < Suc (n - 2)" using kn by auto
    qed
    also have "... = ?M $$ (insert_index 0 (insert_index (k-1) i), insert_index k (insert_index 0 i))"
    proof (rule mat_delete_index[symmetric])
      show "make_mat n k B  carrier_mat (Suc (n-1)) (Suc (n-1))" using i by auto    
      show "insert_index (k - 1) i < n - 1" using kn i
        by (metis diff_Suc_eq_diff_pred diff_commute insert_index_def nat_neq_iff not_less0 
            numeral_2_eq_2 zero_less_diff)
      show "insert_index 0 i < n - 1" using i by auto
    qed (insert kn, auto)
    also have "... = 1" unfolding make_mat_def index_mat[OF i1 i2] 
      by (auto, metis One_nat_def diff_Suc_1 insert_index_exclude) 
         (metis One_nat_def diff_Suc_eq_diff_pred insert_index_def zero_less_diff)+
    finally show ?thesis .
  qed
  have "Determinant.det ?MDMD = prod_list (diag_mat ?MDMD)"
    by (meson assms det_upper_triangular make_mat_carrier mat_delete_carrier 
        upper_triangular_mat_delete_make_mat2)
  also have "... = 1" 
  proof (rule prod_list_neutral)
    fix x assume x: "x  set (diag_mat ?MDMD)"
    from this obtain i where index: "x = ?MDMD $$ (i,i)" and i: "i<dim_row ?MDMD"
      unfolding diag_mat_def by auto
    have "?MDMD $$ (i,i) = 1" by (rule eq1, insert i, auto simp add: make_mat_def)  
    thus "x=1" using index by blast
  qed
  finally show ?thesis .
qed

lemma swaprows_make_mat:
  assumes B: "B  carrier_mat 2 2" and k0: "k0" and k: "k<n"
  shows "swaprows k 0 (make_mat n k B) = make_mat n k (swaprows 1 0 B)" (is "?lhs = ?rhs")
proof (cases "n=0")
  case True
  then show ?thesis
    using make_mat_def by auto
next
  case False
  show ?thesis
   proof (rule eq_matI)
    show "dim_row ?lhs = dim_row ?rhs" and "dim_col ?lhs = dim_col ?rhs"
      by (simp add: make_mat_def)+
  next
    let ?M="(make_mat n k B)"
    fix i j assume i: "i < dim_row ?rhs" and j: "j < dim_col ?rhs"
    hence i2: "i < dim_row ?lhs" and j2: "j < dim_col ?lhs" by (auto simp add: make_mat_def)
    then have i3: "i < dim_row ?M" and j3: "j < dim_col ?M" by auto
    then have i4: "i<n" and j4: "j<n" by (metis carrier_matD(1,2) make_mat_carrier)+
    have lhs: "?lhs $$ (i,j) = 
        (if k = i then ?M $$ (0, j) else if 0 = i then ?M $$ (k, j) else ?M $$ (i, j))"
      by (rule index_mat_swaprows, insert i3 j3, auto)
    also have "... = ?rhs $$ (i,j)" using B i4 j4 False k0 k 
      unfolding make_mat_def index_mat[OF i4 j4] by auto
    finally show "?lhs $$ (i, j) = ?rhs $$ (i, j)" .
  qed
qed


lemma cofactor_make_mat_00:
  assumes k: "k<n" and k0: "k0"
  shows "cofactor (make_mat n k B) 0 0 = B $$ (1,1)"
proof -
  let ?M = "make_mat n k B"
  let ?MD = "mat_delete ?M 0 0"
  have MD_rows: "dim_row ?MD = n-1" by (simp add: make_mat_def)
  have 1: "?MD $$ (i, i) = 1" if i: "i < n - 1" and ik: "Suc i  k" for i
  proof -
    have Suc_i: "Suc i < n" using i by linarith
    have "?MD $$ (i, i) = ?M $$ (insert_index 0 i, insert_index 0 i)"
      by (rule mat_delete_index[symmetric, OF _ _ _ i], insert Suc_i, auto)
    also have "... = ?M $$ (Suc i, Suc i)" by simp
    also have "... = 1" unfolding make_mat_def index_mat[OF Suc_i Suc_i] using ik by auto
    finally show ?thesis .
  qed
  have 2: "?MD $$ (i, i) = B$$(1,1)" if i: "i < n - 1" and ik: "Suc i = k" for i
  proof -
    have Suc_i: "Suc i < n" using i by linarith
    have "?MD $$ (i, i) = ?M $$ (insert_index 0 i, insert_index 0 i)"
      by (rule mat_delete_index[symmetric, OF _ _ _ i], insert Suc_i, auto)   
    also have "... = ?M $$ (Suc i, Suc i)" by simp
    also have "... = B$$(1,1)" unfolding make_mat_def index_mat[OF Suc_i Suc_i] using ik by auto
    finally show ?thesis .
  qed
  have set_rw: "insert (k-1) ({0..<dim_row ?MD}-{k-1}) = {0..<dim_row ?MD}" 
    using k k0 MD_rows by auto
  have up: "upper_triangular ?MD" by (rule upper_triangular_mat_delete_make_mat)
  have "Determinant.cofactor (local.make_mat n k B) 0 0 
    = Determinant.det (mat_delete (make_mat n k B) 0 0)" unfolding cofactor_def by auto
  also have "... = prod_list (diag_mat ?MD)" using up
    using det_upper_triangular make_mat_carrier mat_delete_carrier by blast
  also have "... = (i = 0..<dim_row ?MD. ?MD $$ (i, i))" unfolding prod_list_diag_prod by simp
  also have "... = (i  insert (k-1) ({0..<dim_row ?MD}-{k-1}). ?MD $$ (i, i))" 
    using set_rw by simp
  also have "... = ?MD $$ (k-1, k-1) * (i  {0..<dim_row ?MD} - {k-1}. ?MD $$ (i, i))"
    by (metis (no_types, lifting) Diff_iff finite_atLeastLessThan finite_insert prod.insert set_rw singletonI)
  also have "... = B$$(1,1)"
    by (smt "1" "2" DiffD1 DiffD2 Groups.mult_ac(2) MD_rows add_diff_cancel_left' add_diff_inverse_nat 
        k0 atLeastLessThan_iff class_cring.finprod_all1 insertI1 less_one more_arith_simps(5) 
        plus_1_eq_Suc set_rw)
  finally show ?thesis .
qed



lemma cofactor_make_mat_0k:  
  assumes kn: "k<n" and k0: "k0" and n0: "1<n"
  shows "cofactor (make_mat n k B) 0 k = - B $$ (1,0)"
proof -
  let ?M = "make_mat n k B"
  let ?MD = "mat_delete ?M 0 k"
  have n0: "0<n-1" using n0 by auto
  have MD_carrier: "?MD  carrier_mat (n-1) (n-1)"
    using make_mat_carrier mat_delete_carrier by blast
  have MD_k1: "?MD $$ (k-1, 0) = B $$ (1,0)"
  proof -
    have n0': "0 < n" using n0 by auto
    have insert_i: "insert_index 0 (k-1) = k" using k0 by auto
    have insert_k: "insert_index k 0 = 0" using k0 by auto
    have "?MD $$ (k-1, 0) = ?M $$ (insert_index 0 (k-1), insert_index k 0)"
      by (rule mat_delete_index[symmetric, OF _ _ _ _ n0], insert k0 kn, auto)
    also have "... = ?M $$ (k, 0)" unfolding insert_i insert_k by simp
    also have "... = B $$ (1,0)" using k0 unfolding make_mat_def index_mat[OF kn n0'] by auto
    finally show ?thesis .
  qed  
  have MD0: "?MD $$ (i, 0) = 0" if i: "i<n-1" and ik: "Suc ik" for i
  proof -
    have i2: "Suc i < n" using i by auto
    have n0': "0<n" using n0 by auto
    have insert_i: "insert_index 0 i = Suc i" by simp
    have insert_k: "insert_index k 0 = 0" using k0 by auto
    have "?MD $$ (i, 0) = ?M $$ (insert_index 0 i, insert_index k 0)"
      by (rule mat_delete_index[symmetric, OF _ _ _ i], insert i n0 kn, auto)
    also have "... = ?M $$ (Suc i, 0)" unfolding insert_i insert_k by simp
    also have "... = 0" using ik unfolding make_mat_def index_mat[OF i2 n0'] by auto
    finally show ?thesis .
  qed
  have det_cofactor: "Determinant.cofactor ?MD (k-1) 0 = (-1) ^ (k - 1)"
    unfolding cofactor_def using det_mat_delete_make_mat[OF kn] by auto
  have sum0: "(i{0..<n - 1}-{k-1}. ?MD $$ (i, 0) * Determinant.cofactor ?MD i 0) = 0"
    by (rule sum.neutral, insert MD0, fastforce)
  have "Determinant.det ?MD = (i<n - 1. ?MD $$ (i, 0) * Determinant.cofactor ?MD i 0)" 
    by (rule laplace_expansion_column[OF MD_carrier n0])
  also have "... = ?MD $$ (k-1, 0) * Determinant.cofactor ?MD (k-1) 0 
      + (i{0..<n - 1}-{k-1}. ?MD $$ (i, 0) * Determinant.cofactor ?MD i 0)"  
    by (metis (no_types, lifting) Suc_less_eq add_diff_inverse_nat atLeast0LessThan finite_atLeastLessThan 
        k0 kn lessThan_iff less_one n0 nat_diff_split_asm plus_1_eq_Suc rel_simps(70) sum.remove)
  also have "... = ?MD $$ (k-1, 0) * Determinant.cofactor ?MD (k-1) 0" unfolding sum0 by simp
  also have "... = ?MD $$ (k-1, 0) * (-1) ^ (k - 1)" unfolding det_cofactor by auto
  also have "... = (-1) ^ (k - 1) * B $$ (1,0)" using MD_k1 by auto
  finally show ?thesis unfolding cofactor_def
    by (metis (no_types, lifting) arithmetic_simps(49) k0 left_minus_one_mult_self 
        more_arith_simps(11) mult_minus1 power_eq_if) 
qed


lemma invertible_make_mat:
  assumes inv_B: "invertible_mat B" and B: "B  carrier_mat 2 2" 
    and kn: "k<n" and k0: "k0"
  shows "invertible_mat (make_mat n k B)"
proof -
  let ?M = "(make_mat n k B)"
  have M_carrier: "?M  carrier_mat n n" by auto
  show ?thesis
  proof (cases "n=0")
    case True
    thus ?thesis using M_carrier using invertible_mat_zero by blast
  next
    case False note n_not_0 = False
    show ?thesis
    proof (cases "n=1")
      case True
      then show ?thesis using M_carrier using invertible_mat_zero assms by auto
    next
      case False    
      hence n: "0<n" using n_not_0 by auto
      hence n1: "1<n" using False n_not_0 by auto
      have M00: "?M $$ (0,0) = B $$ (0,0)" by (simp add: make_mat_def n)
      have M0k: "?M $$ (0,k) = B $$ (0,1)" by (simp add: k0 kn make_mat_def n)
      have sum0: "(j({0..<n}-{0} - {k}). ?M $$ (0, j) * Determinant.cofactor ?M 0 j) = 0"
      proof (rule sum.neutral, rule ballI)
        fix x assume x: "x  {0..<n} - {0} - {k}"
        have "make_mat n k B $$ (0,x) = 0" unfolding make_mat_def using x by auto
        thus "local.make_mat n k B $$ (0, x) * Determinant.cofactor (local.make_mat n k B) 0 x = 0" 
          by simp
      qed
      have cofactor_M_00: "Determinant.cofactor ?M 0 0 = B$$(1,1)"
        by (rule cofactor_make_mat_00[OF kn k0])
      have cofactor_M_0k: "Determinant.cofactor ?M 0 k = - B $$ (1,0)"
        by (rule cofactor_make_mat_0k[OF kn k0 n1])
      have "Determinant.det ?M = (j<n. ?M $$ (0, j) * Determinant.cofactor ?M 0 j)" 
        using laplace_expansion_row[OF M_carrier n] by auto
      also have "... = (j{0..<n}. ?M $$ (0, j) * Determinant.cofactor ?M 0 j)" 
        by (rule sum.cong, auto)
      also have "... = ?M $$ (0, 0) * Determinant.cofactor ?M 0 0 
        + ?M $$ (0, k) * Determinant.cofactor ?M 0 k 
        + (j({0..<n}-{0} - {k}). ?M $$ (0, j) * Determinant.cofactor ?M 0 j)" 
        by (metis (no_types, lifting) add_cancel_right_right kn k0 atLeast0LessThan 
            atLeast1_lessThan_eq_remove0 finite_atLeastLessThan insert_Diff_single insert_iff 
            lessThan_iff n sum.atLeast_Suc_lessThan sum.remove sum0)
      also have "... = ?M $$ (0, 0) * Determinant.cofactor ?M 0 0 
        + ?M $$ (0, k) * Determinant.cofactor ?M 0 k" using sum0 by auto
      also have "... = ?M $$ (0, 0) * B $$ (1,1) - ?M $$ (0, k)* B $$ (1,0)" 
        unfolding cofactor_M_00 cofactor_M_0k by auto
      also have "... =  B $$ (0, 0) * B $$ (1,1) - B $$ (0, 1)* B $$ (1,0)" 
        unfolding M00 M0k by auto
      also have "... = Determinant.det B" unfolding det_2[OF B] by auto
      finally have "Determinant.det ?M = Determinant.det B" .
      thus ?thesis unfolding cofactor_def 
        using invertible_iff_is_unit_JNF by (metis B M_carrier inv_B)  
    qed
  qed
qed

lemma make_mat_index:
  assumes i: "i<n" and j: "j<n"
  shows "make_mat n k B $$ (i,j) = (if i = 0  j = 0 then B$$(0,0) else
    if i = 0  j = k then B$$(0,1) else if i=k  j = 0 
      then B$$(1,0) else if i=k  j=k then B$$(1,1) 
      else if i=j then 1 else 0)"
  unfolding make_mat_def index_mat[OF i j] by simp

lemma make_mat_works:
  assumes A: "Acarrier_mat m n" and Suc_i_less_n: "Suc i < n"
    and Q_step_def: "Q_step = (make_mat n (Suc i) (snd (Smith_1x2 
        (Matrix.mat 1 2 (λ(a,b). if b = 0 then A $$ (0,0) else A $$(0,Suc i))))))"
  shows "A $$ (0,0) * Q_step $$ (0,(Suc i)) + A $$ (0, Suc i) * Q_step $$ (Suc i, Suc i) = 0"
proof -
  have n0: "0<n" using Suc_i_less_n by simp
  let ?A ="(Matrix.mat 1 2 (λ(a, b). if b = 0 then A $$ (0, 0) else A $$ (0, Suc i)))"
  let ?S = "fst (Smith_1x2 ?A)"
  let ?Q = "snd (Smith_1x2 ?A)"
  have 1: "(make_mat n (Suc i) ?Q) $$ (0,Suc i) = ?Q $$ (0,1)"
    unfolding make_mat_index[OF n0 Suc_i_less_n] by auto
  have 2: "(make_mat n (Suc i) ?Q) $$ (Suc i, Suc i) = ?Q $$ (1,1)"
    unfolding make_mat_index[OF Suc_i_less_n Suc_i_less_n] by auto
  have is_SNF_A': "is_SNF ?A (1m 1, Smith_1x2 ?A)" using SNF_1x2_works by auto 
  have SNF_S: "Smith_normal_form_mat ?S" and S: "?S = 1m 1 * ?A * ?Q" 
    and Q: "?Q  carrier_mat 2 2"
    using is_SNF_A' unfolding is_SNF_def by auto
  have "?S $$(0,1) = (?A * ?Q) $$(0,1)" unfolding S by auto
  also have "... =  Matrix.row ?A 0  col ?Q 1" by (rule index_mult_mat, insert Q, auto)
  also have "... = (ia = 0..<dim_vec (col ?Q 1). Matrix.row ?A 0 $v ia * col ?Q 1 $v ia)"
    unfolding scalar_prod_def by auto
  also have "... = (ia  {0,1}. Matrix.row ?A 0 $v ia * col ?Q 1 $v ia)"
    by (rule sum.cong, insert Q, auto)
  also have "... = Matrix.row ?A 0 $v 0 * col ?Q 1 $v 0 + Matrix.row ?A 0 $v 1 * col ?Q 1 $v 1"
    using sum_two_elements by auto
  also have "... = A $$ (0,0) * ?Q $$ (0,1) + A $$ (0,Suc i) * ?Q $$ (1,1)"    
    by (smt One_nat_def Q carrier_matD(1) carrier_matD(2) dim_col_mat(1) dim_row_mat(1) index_col 
        index_mat(1) index_row(1) lessI numeral_2_eq_2 pos2 prod.simps(2) rel_simps(93))
  finally have "?S $$(0,1) = A $$ (0,0) * ?Q $$ (0,1) + A $$ (0,Suc i) * ?Q $$ (1,1)" by simp
  moreover have "?S $$(0,1) = 0" using SNF_S unfolding Smith_normal_form_mat_def isDiagonal_mat_def
    by (metis (no_types, lifting) Q S card_num_simps(30) carrier_matD(2) index_mult_mat(2) 
        index_mult_mat(3) index_one_mat(2) lessI n_not_Suc_n numeral_2_eq_2)
  ultimately show ?thesis using 1 2 unfolding Q_step_def by auto
qed

subsubsection ‹Case $1 \times n$›

fun Smith_1xn_aux :: "nat  'a mat  ('a mat × 'a mat)  ('a mat × 'a mat)"
  where 
    "Smith_1xn_aux 0 A (S,Q) = (S,Q)" |
    "Smith_1xn_aux (Suc i) A (S,Q) = (let 
       A_step_1x2 = (Matrix.mat 1 2 (λ(a,b). if b = 0 then S $$ (0,0) else S $$(0,Suc i)));
       (S_step_1x2, Q_step_1x2) = Smith_1x2 A_step_1x2;
      Q_step = make_mat (dim_col A) (Suc i) Q_step_1x2; 
      S' = S * Q_step
      in Smith_1xn_aux i A (S',Q*Q_step))"

definition "Smith_1xn A = (if dim_col A = 0 then (A,1m (dim_col A)) 
  else Smith_1xn_aux (dim_col A - 1) A (A,1m (dim_col A)))"

lemma Smith_1xn_aux_Q_carrier:
  assumes r: "(S',Q') = (Smith_1xn_aux i A (S,Q))"
  assumes A: "A  carrier_mat 1 n" and Q: "Q  carrier_mat n n"
  shows "Q'  carrier_mat n n"
  using A r Q 
proof (induct i A "(S,Q)" arbitrary: S Q rule: Smith_1xn_aux.induct)
  case (1 A S Q)
  then show ?case by auto
next
  case (2 i A S Q)
  note A = "2.prems"(1)
  note S'Q' = "2.prems"(2)
  note Q = "2.prems"(3)  
  let ?A_step_1x2 = "(Matrix.mat 1 2 (λ(a,b). if b = 0 then S $$ (0,0) else S $$(0,Suc i)))"
  let ?S_step_1x2 = "fst (Smith_1x2 ?A_step_1x2)"
  let ?Q_step_1x2 = "snd (Smith_1x2 ?A_step_1x2)"
  let ?Q_step = "make_mat (dim_col A) (Suc i) ?Q_step_1x2"
  have rw: "A * (Q * ?Q_step) = A * Q * ?Q_step"
    by (smt A Q assoc_mult_mat carrier_matD(2) make_mat_carrier)  
  have Smith_rw: "Smith_1xn_aux (Suc i) A (S, Q) = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)"
    by (auto, metis (no_types, lifting) old.prod.exhaust snd_conv split_conv)
  show ?case 
  proof (rule "2.hyps"[of ?A_step_1x2 "(?S_step_1x2, ?Q_step_1x2)" ?S_step_1x2 ?Q_step_1x2])
    show "S * ?Q_step = S * ?Q_step" ..   
    show "A  carrier_mat 1 n" using A by auto
    show "(S', Q') = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)" using "2.prems" Smith_rw by auto
    show "Q * ?Q_step  carrier_mat n n" using A Q by auto  
  qed (auto)
qed


lemma Smith_1xn_aux_invertible_Q:
  assumes r: "(S',Q') = (Smith_1xn_aux i A (S,Q))"
  assumes A: "A  carrier_mat 1 n" and Q: "Q  carrier_mat n n"
    and i: "i<n" and inv_Q: "invertible_mat Q"
  shows "invertible_mat Q'"
  using r A Q inv_Q i
proof (induct i A "(S,Q)" arbitrary: S Q rule: Smith_1xn_aux.induct)
  case (1 A S Q)
  then show ?case by auto
next
  case (2 i A S Q)
  let ?A_step_1x2 = "(Matrix.mat 1 2 (λ(a,b). if b = 0 then S $$ (0,0) else S $$(0,Suc i)))"
  let ?S_step_1x2 = "fst (Smith_1x2 ?A_step_1x2)"
  let ?Q_step_1x2 = "snd (Smith_1x2 ?A_step_1x2)"
  let ?Q_step = "make_mat (dim_col A) (Suc i) ?Q_step_1x2"
   have Smith_rw: "Smith_1xn_aux (Suc i) A (S, Q) = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)"
     by (auto, metis (no_types, lifting) old.prod.exhaust snd_conv split_conv)
   have i_col: "Suc i < dim_col A"
     using  "2.prems" Suc_lessD by blast
   have i_n: "i<n" by (simp add: "2.prems" Suc_lessD)
  show ?case 
  proof (rule "2.hyps"[of ?A_step_1x2 "(?S_step_1x2, ?Q_step_1x2)" ?S_step_1x2 ?Q_step_1x2])
    show "A  carrier_mat 1 n" using "2.prems" by auto
    show "Q * ?Q_step  carrier_mat n n" using "2.prems" by auto  
    show "S * ?Q_step = S * ?Q_step" ..
    show "(S', Q') = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)" using "2.prems" Smith_rw by auto
    show "invertible_mat (Q * ?Q_step)"
    proof (rule invertible_mult_JNF)
      show "Q  carrier_mat n n" using "2.prems" by auto
      show "?Q_step  carrier_mat n n"  using "2.prems" by auto
      show "invertible_mat Q" using "2.prems" by auto
      show "invertible_mat ?Q_step" 
        by (rule invertible_make_mat[OF _ _ i_col], insert SNF_1x2_works, unfold is_SNF_def, auto)
           (metis (no_types, lifting) case_prodE mat_carrier snd_conv)+        
    qed
  qed (auto simp add: i_n)
qed

lemma Smith_1xn_aux_S'_AQ':
  assumes r: "(S',Q') = (Smith_1xn_aux i A (S,Q))"
  assumes A: "A  carrier_mat 1 n" and S: "S  carrier_mat 1 n" and Q: "Q  carrier_mat n n"
    and S_AQ: "S = A*Q" and i: "i<n"
  shows "S' = A * Q'"
  using A S r Q S_AQ 
proof (induct i A "(S,Q)" arbitrary: S Q rule: Smith_1xn_aux.induct)
  case (1 A S Q)
  then show ?case by auto
next
 case (2 i A S Q)
  let ?A_step_1x2 = "(Matrix.mat 1 2 (λ(a,b). if b = 0 then S $$ (0,0) else S $$(0,Suc i)))"
  let ?S_step_1x2 = "fst (Smith_1x2 ?A_step_1x2)"
  let ?Q_step_1x2 = "snd (Smith_1x2 ?A_step_1x2)"
  let ?Q_step = "make_mat (dim_col A) (Suc i) ?Q_step_1x2"
  have rw: "A * (Q * ?Q_step) = A * Q * ?Q_step"
    by (smt "2.prems" assoc_mult_mat carrier_matD(2) make_mat_carrier)  
   have Smith_rw: "Smith_1xn_aux (Suc i) A (S, Q) = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)"
    by (auto, metis (no_types, lifting) old.prod.exhaust snd_conv split_conv)
  show ?case 
  proof (rule "2.hyps"[of ?A_step_1x2 "(?S_step_1x2, ?Q_step_1x2)" ?S_step_1x2 ?Q_step_1x2])
   show "A  carrier_mat 1 n" using "2.prems" by auto
    show "Q * ?Q_step  carrier_mat n n" using "2.prems" by auto  
    show "S * ?Q_step = S * ?Q_step" ..
    show "(S', Q') = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)" using "2.prems" Smith_rw by auto
    show " S * ?Q_step = A * (Q * ?Q_step)" using "2.prems" rw by auto
    show "S * ?Q_step  carrier_mat 1 n"
      using "2.prems" by (smt carrier_matD(2) make_mat_carrier mult_carrier_mat)
  qed (auto)
qed


lemma Smith_1xn_aux_S'_works:
  assumes r: "(S',Q') = (Smith_1xn_aux i A (S,Q))"
  assumes A: "A  carrier_mat 1 n" and S: "S  carrier_mat 1 n" and Q: "Q  carrier_mat n n"
    and S_AQ: "S = A*Q" and i: "i<n" and j0: "0<j" and jn: "j<n"
  and all_j_zero: "j{i+1..<n}. S $$(0,j) = 0"
  shows "S' $$ (0,j) = 0"
  using A S r Q i S_AQ all_j_zero j0 jn
proof (induct i A "(S,Q)" arbitrary: S Q rule: Smith_1xn_aux.induct)
  case (1 A S Q)
  then show ?case using j0 jn by auto
next
 case (2 i A S Q)
  let ?A_step_1x2 = "(Matrix.mat 1 2 (λ(a,b). if b = 0 then S $$ (0,0) else S $$(0,Suc i)))"
  let ?S_step_1x2 = "fst (Smith_1x2 ?A_step_1x2)"
  let ?Q_step_1x2 = "snd (Smith_1x2 ?A_step_1x2)"
  let ?Q_step = "make_mat (dim_col A) (Suc i) ?Q_step_1x2"
  have i_less_n: "i<n" by (simp add: "2"(6) Suc_lessD)
  have rw: "A * (Q * ?Q_step) = A * Q * ?Q_step"
    by (smt "2.prems" assoc_mult_mat carrier_matD(2) make_mat_carrier)  
   have Smith_rw: "Smith_1xn_aux (Suc i) A (S, Q) = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)"
     by (auto, metis (no_types, lifting) old.prod.exhaust snd_conv split_conv)
   have S'_AQ': "S' = A*Q'"
     by (rule Smith_1xn_aux_S'_AQ', insert "2.prems", auto)  
  show ?case 
  proof (rule "2.hyps"[of ?A_step_1x2 "(?S_step_1x2, ?Q_step_1x2)" ?S_step_1x2 ?Q_step_1x2])
   show "A  carrier_mat 1 n" using "2.prems" by auto
    show Q_Q_step_carrier: "Q * ?Q_step  carrier_mat n n" using "2.prems" by auto  
    show "S * ?Q_step = S * ?Q_step" ..
    show "(S', Q') = Smith_1xn_aux i A (S * ?Q_step, Q * ?Q_step)" using "2.prems" Smith_rw by auto
    show "S * ?Q_step = A * (Q * ?Q_step)" using "2.prems" rw by auto
    show "S * ?Q_step  carrier_mat 1 n"      
      using "2.prems" by (smt carrier_matD(2) make_mat_carrier mult_carrier_mat)  
    show "j{i + 1..<n}. (S * ?Q_step) $$ (0, j) = 0"
    proof (rule ballI)
      fix j assume j: "j{i + 1..<n}" 
      have "(S * ?Q_step) $$ (0, j) = Matrix.row S 0  col ?Q_step j" 
        by (rule index_mult_mat, insert j "2.prems", auto simp add: make_mat_def)
      also have "... = 0"
      proof (cases "j=Suc i")
        case True
        (*In this case, the element is transformed into a zero thanks to the SNF operation.*)
        let ?f = "λx. Matrix.row S 0 $v x * col ?Q_step j $v x"
        let ?set = "{0..<dim_vec (col ?Q_step j)}"
        have set_rw: "?set = insert 0 (insert j (?set - {0} - {j}))"
          using "2.prems" True make_mat_def by auto
        have sum0: "(x  ?set - {0} - {j}. ?f x) = 0"
        proof (rule sum.neutral, rule ballI)
          fix x assume x: "x  ?set - {0} - {j}"
          show "?f x = 0" using "2"(6) "2.prems" True make_mat_def x by auto
        qed
        have "Matrix.row S 0  col ?Q_step j  = (x = 0..<dim_vec (col ?Q_step j). ?f x)"
          unfolding scalar_prod_def by simp
        also have "... = (x  insert 0 (insert j (?set - {0} - {j})). ?f x)" using set_rw by auto
        also have "... = ?f 0 + (x  insert j (?set - {0} - {j}). ?f x)" by (simp add: True)
        also have "... = ?f 0 + ?f j + (x  ?set - {0} - {j}. ?f x)"
          by (simp add: set_rw sum.insert_remove)
        also have "... = ?f 0 + ?f j" using sum0 by auto
        also have "... = S $$ (0,0) * ?Q_step $$ (0, Suc i) + S $$ (0,Suc i) * ?Q_step $$ (Suc i, Suc i)"
          using "2.prems" True make_mat_def by auto
        also have "... = 0" by (rule make_mat_works, insert "2.prems", auto)
        finally show ?thesis .
      next
        (*In this case, the zeroes are preserved. Each multiplication is zero.*)
        case False note j_not_Suc_i = False
        show ?thesis
          unfolding scalar_prod_def
        proof (rule sum.neutral, rule ballI)
          fix x assume x: "x{0..<dim_vec (col ?Q_step j)}"
          have xn: "x<n" using "2"(2) make_mat_def x by auto
          have jn2: "j<dim_col A" using "2"(2) j by auto
          have xn2: "x<dim_col A" using "2.prems"(1) xn by blast
          have "Matrix.row S 0 $v x = S $$ (0,x)" using "2.prems" make_mat_def x by auto
          moreover have "col ?Q_step j $v x = ?Q_step $$ (x,j)" using Q_Q_step_carrier j x by auto
          ultimately have eq: "Matrix.row S 0 $v x * col ?Q_step j $v x = S $$ (0,x) * ?Q_step $$ (x,j)" by auto
          have S_0x: "S $$ (0,x) = 0" if "Suc i + 1  x" using "2.prems" xn that by auto
          moreover have "?Q_step $$ (x,j) = 0" if "xSuc i" 
            using that j j_not_Suc_i unfolding make_mat_def index_mat[OF xn2 jn2] by auto 
          ultimately show "Matrix.row S 0 $v x * (col ?Q_step j) $v x = 0" using eq by force
        qed
      qed
      finally show "(S * ?Q_step) $$ (0, j) = 0" .
    qed
  qed (auto simp add: "2.prems" i_less_n)
qed

lemma Smith_1xn_works:
  assumes A: "A  carrier_mat 1 n"
  and SQ: "(S,Q) = Smith_1xn A"
shows "is_SNF A (1m 1, S,Q)"
proof (cases "n=0")
  case True
  thus ?thesis using assms
    unfolding is_SNF_def
    by (auto simp add: Smith_1xn_def)
next
  case False 
  hence n0: "0<n" by auto
  show ?thesis
  proof (rule is_SNF_intro) 
    have SQ_eq: "(S,Q) = local.Smith_1xn_aux (dim_col A - 1) A (A,1m (dim_col A))"
      using SQ unfolding Smith_1xn_def by simp
    have col: "dim_col A - 1 < dim_col A" using n0 A by auto
    show "1m 1  carrier_mat (dim_row A) (dim_row A)" using A by auto
    show Q: "Q  carrier_mat (dim_col A) (dim_col A)" 
      by (rule Smith_1xn_aux_Q_carrier[OF SQ_eq], insert A, auto)
    show "invertible_mat (1m 1)" by simp
    show "invertible_mat Q" by (rule Smith_1xn_aux_invertible_Q[OF SQ_eq], insert A n0, auto)
    have S_AQ: "S = A * Q"
      by (rule Smith_1xn_aux_S'_AQ'[OF SQ_eq], insert A n0, auto)
    thus "S = 1m 1 * A * Q" using A by auto
    have S: "S  carrier_mat 1 n" using S_AQ A Q by auto  
    show "Smith_normal_form_mat S"
    proof (rule Smith_normal_form_mat_intro)
      show "a. a + 1 < min (dim_row S) (dim_col S)  S $$ (a, a) dvd S $$ (a + 1, a + 1)"
        using S by auto
      have "S $$ (0, j) = 0" if j0: "0 < j" and jn: "j < n" for j
        by (rule Smith_1xn_aux_S'_works[OF SQ_eq], insert A n0 j0 jn, auto)  
      thus "isDiagonal_mat S" unfolding isDiagonal_mat_def using S by simp   
    qed
  qed
qed

subsubsection ‹Case $n \times 1$›

(*The case n x 1 can be obtained from the case 1 x n taking inverses appropriately. Thus, I get
  rid of the Smith_2x1 operation, since it seems to be useless.*)

definition "Smith_nx1 A = 
  (let (S,P) = (Smith_1xn_aux (dim_row A - 1) (transpose_mat A) (transpose_mat A,1m (dim_row A))) 
  in (transpose_mat P, transpose_mat S))"


lemma Smith_nx1_works:
  assumes A: "A  carrier_mat n 1"
  and SQ: "(P,S) = Smith_nx1 A"
shows "is_SNF A (P, S,1m 1)"
proof (cases "n=0")
  case True
  thus ?thesis using assms
    unfolding is_SNF_def
    by (auto simp add: Smith_nx1_def)
next
  case False
  hence n0: "0<n" by auto
  show ?thesis
  proof (rule is_SNF_intro) 
    have SQ_eq: "(ST, PT) = (Smith_1xn_aux (dim_row A - 1) AT (AT,1m (dim_row A)))"
      using SQ[unfolded Smith_nx1_def] unfolding Let_def split_beta by auto
    have "is_SNF (AT) (1m 1, ST,PT)" 
      by (rule Smith_1xn_works[unfolded Smith_1xn_def, OF _ _], insert SQ_eq A, auto)
    have Pt: "PT  carrier_mat (dim_col (AT)) (dim_col (AT))"
      by (rule Smith_1xn_aux_Q_carrier[OF SQ_eq], insert A n0, auto)
    thus P: "P  carrier_mat (dim_row A) (dim_row A)" by auto
    show "1m 1  carrier_mat (dim_col A) (dim_col A)" using A by simp
    have "invertible_mat (PT)"
      by (rule Smith_1xn_aux_invertible_Q[OF SQ_eq], insert A n0, auto)
    thus "invertible_mat P" by (metis det_transpose P Pt invertible_iff_is_unit_JNF)
    show "invertible_mat (1m 1)" by simp
    have "ST = AT * PT" 
      by (rule Smith_1xn_aux_S'_AQ'[OF SQ_eq], insert A n0, auto)
    hence "S = P * A" by (metis A transpose_mult transpose_transpose P carrier_matD(1))
    thus "S = P * A * 1m 1" using P A by auto
    hence S: "S  carrier_mat n 1" using P A by auto
    have "is_SNF (AT) (1m 1, ST,PT)" 
      by (rule Smith_1xn_works[unfolded Smith_1xn_def, OF _ _], insert SQ_eq A, auto)  
    hence "Smith_normal_form_mat (ST)" unfolding is_SNF_def by auto
    thus "Smith_normal_form_mat S" unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto
  qed
qed

subsubsection ‹Case $2 \times n$›

function Smith_2xn :: "'a mat  ('a mat × 'a mat × 'a mat)"
  where 
    "Smith_2xn A = (
  if dim_col A = 0 then (1m (dim_row A),A,1m 0) else
  if dim_col A = 1 then let (P,S) = Smith_nx1 A in (P,S, 1m (dim_col A)) else
  if dim_col A = 2 then Smith_2x2 A 
  else
      let A1 = mat_of_cols (dim_row A) [col A 0];
          A2 = mat_of_cols (dim_row A) [col A i. i  [1..<dim_col A]];
          (P1,D1,Q1) = Smith_2xn A2;
          C = (P1*A1) @c (P1*A2*Q1);
          D = mat_of_cols (dim_row A) [col C 0, col C 1];
          E = mat_of_cols (dim_row A) [col C i. i  [2..<dim_col A]];
          (P2,D2,Q2) = Smith_2x2 D;
          H = (P2*D*Q2) @c (P2 * E);
          k = (div_op (H $$ (0,2)) (H $$ (0,0)));
          H2 = addcol (-k) 2 0 H;
          (_,_,_,H2_DR) = split_block H2 1 1;
          (H_1xn,Q3) = Smith_1xn H2_DR;
          S = four_block_mat (Matrix.mat 1 1 (λ(a,b). H$$(0,0))) (0m 1 (dim_col A - 1)) (0m 1 1) H_1xn;
          Q1' = four_block_mat (1m 1) (0m 1 (dim_col A - 1)) (0m (dim_col A - 1) 1) Q1;
          Q2' = four_block_mat Q2 (0m 2 (dim_col A - 2)) (0m (dim_col A - 2) 2) (1m (dim_col A - 2));
          Q_div_k = addrow_mat (dim_col A) (-k) 0 2;
          Q3' = four_block_mat (1m 1) (0m 1 (dim_col A - 1)) (0m (dim_col A - 1) 1) Q3
      in (P2 * P1,S,Q1' * Q2' * Q_div_k * Q3'))"
  by pat_completeness auto
(*Termination is guaranteed since the algorithm is recursively applied to a 
  submatrix with less columns*)
termination apply (relation "measure (λA. dim_col A)") by auto

lemma Smith_2xn_0:
  assumes A: "A  carrier_mat 2 0"
  shows "is_SNF A (Smith_2xn A)"
proof -
  have "Smith_2xn A = (1m (dim_row A),A,1m 0)"
    using A by auto
  moreover have "is_SNF A ..." by (rule is_SNF_intro, insert A, auto)
  ultimately show ?thesis by simp
qed

lemma Smith_2xn_1:
  assumes A: "A  carrier_mat 2 1"
  shows "is_SNF A (Smith_2xn A)"
proof -
  obtain P S where PS: "Smith_nx1 A = (P,S)" using prod.exhaust by blast
  have *: "is_SNF A (P, S,1m 1)" by (rule Smith_nx1_works[OF A PS[symmetric]])
  moreover have "Smith_2xn A = (P,S, 1m (dim_col A))"
    using A PS by auto
  moreover have "is_SNF A ..." using * A by auto
  ultimately show ?thesis by simp
qed

lemma Smith_2xn_2:
  assumes A: "A  carrier_mat 2 2"
  shows "is_SNF A (Smith_2xn A)"
proof -
  have "Smith_2xn A = Smith_2x2 A" using A by auto
  from this show ?thesis using SNF_2x2_works using A by auto
qed

lemma is_SNF_Smith_2xn_n_ge_2: 
  assumes A: "A  carrier_mat 2 n" and n: "n>2"
  shows "is_SNF A (Smith_2xn A)"
  using A n id
proof (induct A arbitrary: n rule: Smith_2xn.induct)
  case (1 A)
  note A = "1.prems"(1)
  note n_ge_2 = "1.prems"(2)
  have dim_col_A_g2: "dim_col A > 2" using n_ge_2 A by auto
  define A1 where "A1 = mat_of_cols (dim_row A) [col A 0]"
  define A2 where "A2 = mat_of_cols (dim_row A) [col A i. i  [1..<dim_col A]]"
  obtain P1 D1 Q1 where P1D1Q1: "(P1,D1,Q1) = Smith_2xn A2" by (metis prod_cases3)
  define C where "C = (P1*A1) @c (P1*A2*Q1)"
  define D where "D = mat_of_cols (dim_row A) [col C 0, col C 1]"
  define E where "E = mat_of_cols (dim_row A) [col C i. i  [2..<dim_col A]]"
  obtain P2 D2 Q2 where P2D2Q2: "(P2,D2,Q2) = Smith_2x2 D" by (metis prod_cases3)
  define H where "H = (P2*D*Q2) @c (P2 * E)"
  define k where "k = div_op (H $$ (0,2)) (H $$ (0,0))"
  define H2 where "H2 = addcol (-k) 2 0 H"
  obtain H2_UL H2_UR H2_DL H2_DR 
    where split_H2: "(H2_UL, H2_UR, H2_DL, H2_DR) = (split_block H2 1 1)" by (metis prod_cases4)
  obtain H_1xn Q3 where H_1xn_Q3: "(H_1xn,Q3) = Smith_1xn H2_DR" by (metis surj_pair)
  define S where "S = four_block_mat (Matrix.mat 1 1 (λ(a,b). H$$(0,0))) (0m 1 (dim_col A - 1)) (0m 1 1) H_1xn"
  define Q1' where "Q1' = four_block_mat (1m 1) (0m 1 (dim_col A - 1)) (0m (dim_col A - 1) 1) Q1"
  define Q2' where "Q2' = four_block_mat Q2 (0m 2 (dim_col A - 2)) (0m (dim_col A - 2) 2) (1m (dim_col A - 2))"
  define Q_div_k where "Q_div_k = addrow_mat (dim_col A) (-k) 0 2"
  define Q3' where "Q3' = four_block_mat (1m 1) (0m 1 (dim_col A - 1)) (0m (dim_col A - 1) 1) Q3"
  have Smith_2xn_rw: "Smith_2xn A = (P2 * P1, S, Q1' * Q2' * Q_div_k * Q3')"
  proof (rule prod3_intro)
    have P1_def: "fst (Smith_2xn A2) = P1" and Q1_def: "snd (snd (Smith_2xn A2)) = Q1"
    and P2_def: "fst (Smith_2x2 D) = P2" and Q2_def: "snd (snd (Smith_2x2 D)) = Q2"
    and H_1xn_def: "fst (Smith_1xn H2_DR) = H_1xn" and Q3_def: "snd (Smith_1xn H2_DR) = Q3"     
    and H2_DR_def: "snd (snd (snd (split_block H2 1 1))) = H2_DR"
      using P2D2Q2 P1D1Q1 H_1xn_Q3 split_H2 fstI sndI by metis+
    note aux= P1_def Q1_def Q1'_def Q2'_def Q_div_k_def Q3'_def S_def A1_def[symmetric]
      C_def[symmetric] P2_def Q2_def Q3_def D_def[symmetric] E_def[symmetric] H_def[symmetric]
      k_def[symmetric] H2_def[symmetric] H2_DR_def H_1xn_def A2_def[symmetric]
  show "fst (Smith_2xn A) = P2 * P1" 
    using dim_col_A_g2 unfolding Smith_2xn.simps[of A] Let_def split_beta
    by (insert P1D1Q1 P2D2Q2 D_def C_def, unfold aux, auto simp del: Smith_2xn.simps)
  show "fst (snd (Smith_2xn A)) = S"
    using dim_col_A_g2 unfolding Smith_2xn.simps[of A] Let_def split_beta
    by (insert P1D1Q1 P2D2Q2, unfold aux, auto simp del: Smith_2xn.simps)
  show "snd (snd (Smith_2xn A)) = Q1' * Q2' * Q_div_k * Q3'" 
    using dim_col_A_g2 unfolding Smith_2xn.simps[of A] Let_def split_beta
    by (insert P1D1Q1 P2D2Q2, unfold aux, auto simp del: Smith_2xn.simps)  
  qed
  show ?case
  proof (unfold Smith_2xn_rw, rule is_SNF_intro)    
    have is_SNF_A2: "is_SNF A2 (Smith_2xn A2)" 
    proof (cases "2<dim_col A2")
      case True
      show ?thesis 
        by (rule "1.hyps", insert True A dim_col_A_g2 id, auto simp add: A2_def)
    next
      case False
      hence "dim_col A2 = 2" using n_ge_2 A unfolding A2_def by auto
      hence A2: "A2carrier_mat 2 2" unfolding A2_def using A by auto
      hence *: "Smith_2xn A2 =  Smith_2x2 A2" by auto
      show ?thesis unfolding * using SNF_2x2_works A2 by auto
    qed
    have A1[simp]: "A1  carrier_mat (dim_row A) 1" unfolding A1_def by auto
    have A2[simp]: "A2  carrier_mat (dim_row A) (dim_col A - 1)" unfolding A2_def by auto    
    have P1[simp]: "P1  carrier_mat (dim_row A) (dim_row A)" 
      and inv_P1: "invertible_mat P1" 
      and Q1: "Q1  carrier_mat (dim_col A2) (dim_col A2)" and inv_Q1: "invertible_mat Q1"
      and SNF_P1A2Q1: "Smith_normal_form_mat (P1*A2*Q1)"
      using is_SNF_A2 P1D1Q1 A2 unfolding is_SNF_def by fastforce+ 
    have D[simp]: "D  carrier_mat 2 2" unfolding D_def
      by (metis "1"(2) One_nat_def Suc_eq_plus1 carrier_matD(1) list.size(3) 
          list.size(4) mat_of_cols_carrier(1) numerals(2))
    have is_SNF_D: "is_SNF D (Smith_2x2 D)" using SNF_2x2_works D by auto
    hence P2[simp]: "P2  carrier_mat (dim_row A) (dim_row A)" and inv_P2: "invertible_mat P2"
      and Q2[simp]: "Q2  carrier_mat (dim_col D) (dim_col D)" and inv_Q2: "invertible_mat Q2"
      using P2D2Q2 D_def unfolding is_SNF_def by force+ 
    show P2_P1: "P2 * P1  carrier_mat (dim_row A) (dim_row A)" by (rule mult_carrier_mat[OF P2 P1])
    show "invertible_mat (P2 * P1)" by (rule invertible_mult_JNF[OF P2 P1 inv_P2 inv_P1])
    have Q1': "Q1'  carrier_mat (dim_col A) (dim_col A)" using Q1 unfolding Q1'_def
      by (auto, smt A2 One_nat_def add_diff_inverse_nat carrier_matD(1) carrier_matD(2) carrier_matI 
          dim_col_A_g2 gr_implies_not0 index_mat_four_block(2) index_mat_four_block(3) 
          index_one_mat(2) index_one_mat(3) less_Suc0)
    have Q2': "Q2'  carrier_mat (dim_col A) (dim_col A)" using Q2 unfolding Q2'_def
      by (smt D One_nat_def Suc_lessD add_diff_inverse_nat carrier_matD(1) carrier_matD(2) 
          carrier_matI dim_col_A_g2 gr_implies_not0 index_mat_four_block(2) index_mat_four_block(3)
          index_one_mat(2) index_one_mat(3) less_2_cases numeral_2_eq_2 semiring_norm(138))
   have H2[simp]: "H2  carrier_mat (dim_row A) (dim_col A)" using A P2 D unfolding H2_def H_def
     by (smt E_def Q2 Q2' Q2'_def append_cols_def arithmetic_simps(50) carrier_matD(1) carrier_matD(2) 
         carrier_mat_triv index_mat_addcol(4) index_mat_addcol(5) index_mat_four_block(2) 
         index_mat_four_block(3) index_mult_mat(2) index_mult_mat(3) index_one_mat(2) index_zero_mat(2) 
         index_zero_mat(3) length_map length_upt mat_of_cols_carrier(3))
   have H'[simp]: "H2_DR  carrier_mat 1 (n - 1)"
     by (rule split_block(4)[OF split_H2[symmetric]], insert H2 A n_ge_2, auto)
   have is_SNF_H': "is_SNF H2_DR (1m 1, H_1xn, Q3)"
     by (rule Smith_1xn_works[OF H' H_1xn_Q3])
   from this have Q3: "Q3  carrier_mat (dim_col H2_DR) (dim_col H2_DR)" and inv_Q3: "invertible_mat Q3" 
     unfolding is_SNF_def by auto
   have Q3': "Q3'  carrier_mat (dim_col A) (dim_col A)"
     by (metis A A2 H' Q1 Q1' Q1'_def Q3 Q3'_def carrier_matD(1) carrier_matD(2) carrier_matI 
         index_mat_four_block(2) index_mat_four_block(3))   
   have Q_div_k[simp]: "Q_div_k  carrier_mat (dim_col A) (dim_col A)" unfolding Q_div_k_def by auto
   have inv_Q_div_k: "invertible_mat Q_div_k"
     by (metis Q_div_k Q_div_k_def det_addrow_mat det_one invertible_iff_is_unit_JNF 
         invertible_mat_one nat.simps(3) numerals(2) one_carrier_mat)
   show "Q1' * Q2' * Q_div_k * Q3'  carrier_mat (dim_col A) (dim_col A)"
     using Q1' Q2' Q_div_k Q3' by auto
   have inv_Q1': "invertible_mat Q1'"
   proof -
     have "invertible_mat (four_block_mat (1m 1) (0m 1 (n - 1)) (0m (n - 1) 1) Q1)"
       by (rule invertible_mat_four_block_mat_lower_right, insert Q1 inv_Q1 A2 "1.prems", auto)
     thus ?thesis unfolding Q1'_def using A by auto
   qed
   have inv_Q2': "invertible_mat Q2'"
     by (unfold Q2'_def, rule invertible_mat_four_block_mat_lower_right_id, 
         insert Q2 n_ge_2 inv_Q2 A D, auto)
   have inv_Q3': "invertible_mat Q3'"
   proof -
     have "invertible_mat (four_block_mat (1m 1) (0m 1 (n - 1)) (0m (n - 1) 1) Q3)"
       by (rule invertible_mat_four_block_mat_lower_right, insert Q3 H' inv_Q3 "1.prems", auto)
     thus ?thesis unfolding Q3'_def using A by auto
   qed
   show "invertible_mat (Q1' * Q2' * Q_div_k * Q3')"
     using inv_Q1' inv_Q2' inv_Q_div_k inv_Q3'
     by (meson Q1' Q2' Q3' Q_div_k invertible_mult_JNF mult_carrier_mat)
   have A_A1_A2: "A = A1 @c A2" unfolding A1_def A2_def append_cols_def 
   proof (rule eq_matI, auto)
     fix i assume i: "i < dim_row A" show 1: "A $$ (i, 0) = mat_of_cols (dim_row A) [col A 0] $$ (i, 0)"       
       by (metis dim_col_A_g2 gr_zeroI i index_col mat_of_cols_Cons_index_0 not_less0)
     let ?xs = "(map (col A) [Suc 0..<dim_col A])"
     fix j
     assume j1: "j < Suc (dim_col A - Suc 0)"
       and j2: "0 < j" 
     have "mat_of_cols (dim_row A) ?xs $$ (i, j - Suc 0) = ?xs ! (j - Suc 0) $v i"
       by (rule mat_of_cols_index, insert j1 j2 i, auto)
     also have "... = A $$ (i,j)" using dim_col_A_g2 i j1 j2 by auto
     finally show "A $$ (i, j) = mat_of_cols (dim_row A) ?xs $$ (i, j - Suc 0)" ..         
     next
       show "dim_col A = Suc (dim_col A - Suc 0)" using n_ge_2 A by auto
   qed
   have C_P1_A_Q1': "C = P1 * A * Q1'"
   proof -
     have aux: "P1 * (A1 @c A2) = ((P1 * A1) @c (P1 * A2))" 
       by (rule append_cols_mult_left, insert A1 A2 P1, auto)
     have "P1 * A * Q1' = P1 * (A1 @c A2) * Q1'" using A_A1_A2 by simp     
     also have "... = ((P1 * A1) @c (P1 * A2)) * Q1'" unfolding aux ..
     also have "... = (P1 * A1) @c ((P1 * A2) * Q1)"
       by (rule append_cols_mult_right_id, insert P1 A1 A2 Q1'_def Q1, auto)
     finally show ?thesis unfolding C_def by auto
   qed
   have E_ij_0: "E $$ (i,j) = 0" if i: "i<dim_row E" and j: "j<dim_col E" and ij: "(i,j)  (1,0)" 
      for i j
   proof -
     let ?ws = "(map (col C) [2..<dim_col A])"
     have "E $$ (i,j) = ?ws ! j $v i " 
       by (unfold E_def, rule mat_of_cols_index, insert i j A E_def, auto)
     also have "... = (col C (j+2)) $v i" using E_def j by auto
     also have "... = C $$ (i,j+2)" 
       by (metis C_P1_A_Q1' P1 Q1' E_def carrier_matD(1) carrier_matD(2) index_col index_mult_mat(2)
           index_mult_mat(3) length_map length_upt less_diff_conv mat_of_cols_carrier(2)
           mat_of_cols_carrier(3) i j)
     also have "... = (if j + 2 < dim_col (P1*A1) then (P1*A1) $$ (i, j + 2) 
        else (P1 * A2 * Q1) $$ (i, (j+2) - 1))" 
       unfolding C_def 
       by (rule append_cols_nth, insert i j P1 A1 A2 Q1 A, auto simp add: E_def)    
     also have "... = (P1 * A2 * Q1) $$ (i, j+1)"
       by (metis A1 One_nat_def add.assoc add_diff_cancel_right' add_is_0 arith_special(3) 
           carrier_matD(2) index_mult_mat(3) less_Suc0 zero_neq_numeral)
     also have "... = 0" using SNF_P1A2Q1 unfolding Smith_normal_form_mat_def isDiagonal_mat_def
       by (metis (no_types, lifting) A A2 P1 Q1 Suc_diff_Suc Suc_mono E_def add_Suc_right 
           add_lessD1 arith_extra_simps(6) carrier_matD(1) carrier_matD(2) dim_col_A_g2 
           gr_implies_not0 index_mult_mat(2) index_mult_mat(3) length_map length_upt less_Suc_eq 
           mat_of_cols_carrier(2) mat_of_cols_carrier(3) numeral_2_eq_2 plus_1_eq_Suc i j ij)
     finally show ?thesis .
   qed
   have C_D_E: "C = D @c E"
   proof (rule eq_matI)
     have "C $$ (i, j) = mat_of_cols (dim_row A) [col C 0, col C 1] $$ (i, j)" 
       if  i: "i < dim_row A" and j: "j < 2" for i j
     proof -
       let ?ws = "[col C 0, col C 1]"
       have "mat_of_cols (dim_row A) [col C 0, col C 1] $$ (i, j) = ?ws ! j $v i"
         by (rule mat_of_cols_index, insert i j, auto)       
       also have "... = C $$ (i, j)" using j index_col 
         by (auto, smt A C_P1_A_Q1' P1 Q1' Suc_lessD carrier_matD i index_col index_mult_mat(2,3) 
             less_2_cases n_ge_2 nth_Cons_0 nth_Cons_Suc numeral_2_eq_2)
       finally show ?thesis by simp
     qed
     moreover have "C $$ (i, j) = mat_of_cols (dim_row A) (map (col C) [2..<dim_col A]) $$ (i, j - 2)"
       if i: "i < dim_row A" and j1: "j < dim_col A" and j2: "j  2" for i j
     proof -
       let ?ws = "(map (col C) [2..<dim_col A])"
       have "mat_of_cols (dim_row A) ?ws $$ (i, j - 2) = ?ws ! (j-2) $v i"
         by (rule mat_of_cols_index, insert i j1 j2, auto)       
       also have "... = C $$ (i,j)"
         by (metis C_P1_A_Q1' P1 Q1' add_diff_inverse_nat carrier_matD(1) carrier_matD(2) dim_col_A_g2 
             i index_col index_mult_mat(2) index_mult_mat(3) less_diff_iff less_imp_le_nat 
             linorder_not_less nth_map_upt j1 j2)
       finally show ?thesis by auto
     qed
     ultimately show "i j. i < dim_row (D @c E)  j < dim_col (D @c E)  C $$ (i, j) = (D @c E) $$ (i, j)" 
       unfolding D_def E_def append_cols_def by (auto simp add: numerals)
     show "dim_row C = dim_row (D @c E)" using P1 A unfolding C_def D_def E_def append_cols_def by auto
     show "dim_col C = dim_col (D @c E)" using A1 Q1 A2 A n_ge_2 
       unfolding C_def D_def E_def append_cols_def by auto
   qed
   have E[simp]: "Ecarrier_mat 2 (n-2)" unfolding E_def using A by auto 
   have H[simp]: "H  carrier_mat (dim_row A) (dim_col A)" unfolding H_def append_cols_def using A
     by (smt E Groups.add_ac(1) One_nat_def P2_P1 Q2 Q2' Q2'_def carrier_matD index_mat_four_block
          plus_1_eq_Suc index_mult_mat index_one_mat index_zero_mat numeral_2_eq_2 carrier_matI)
   have H_P2_P1_A_Q1'_Q2': "H = P2 * P1 * A * Q1' * Q2'"
   proof -
     have aux: "(P2 * D @c P2 * E) = P2 * (D @c E)"
       by (rule append_cols_mult_left[symmetric], insert D E P2 A, auto simp add: D_def E_def)
     have "H = P2 * D * Q2 @c P2 * E" using H_def by auto
     also have "... = (P2 * D @c P2 * E) * Q2'" by (rule append_cols_mult_right_id2[symmetric],
           insert Q2 D Q2'_def, auto simp add: D_def E_def)
     also have "... = (P2 * (D @c E)) * Q2'" using aux by auto
     also have "... = P2 * C * Q2'" unfolding C_D_E by auto
     also have "... = P2 * P1 * A * Q1' * Q2'" unfolding C_P1_A_Q1'
       by (smt P1 P2 Q1' P2_P1 assoc_mult_mat carrier_mat_triv index_mult_mat(2))
     finally show ?thesis .
   qed
   have H2_H_Q_div_k: "H2 = H * Q_div_k" unfolding H2_def Q_div_k_def
     by (metis H_P2_P1_A_Q1'_Q2' Q2' addcol_mat carrier_matD(2) dim_col_A_g2 gr_implies_not0 
         mat_carrier times_mat_def zero_order(5))
   hence H2_P2_P1_A_Q1'_Q2'_Q_div_k: "H2 = P2 * P1 * A * Q1' * Q2' * Q_div_k"
     unfolding H_P2_P1_A_Q1'_Q2' by simp
   have H2_as_four_block_mat: "H2 = four_block_mat H2_UL H2_UR H2_DL H2_DR" 
     by (rule split_block[OF split_H2[symmetric], of _ "n-1"], insert H2 A n_ge_2, auto)
   have H2_UL: "H2_UL  carrier_mat 1 1"
     by (rule split_block[OF split_H2[symmetric], of _ "n-1"], insert H2 A n_ge_2, auto)
   have H2_UR: "H2_UR  carrier_mat 1 (dim_col A - 1)"
     by (rule split_block(2)[OF split_H2[symmetric]], insert H2 A n_ge_2, auto)
   have H2_DL: "H2_DL  carrier_mat 1 1"
     by (rule split_block[OF split_H2[symmetric], of _ "n-1"], insert H2 A n_ge_2, auto)
   have H2_DR: "H2_DR  carrier_mat 1 (dim_col A - 1)"
     by (rule split_block[OF split_H2[symmetric]], insert H2 A n_ge_2, auto)
   have H2_UR_00: "H2_UR $$ (0,0) = 0"
   proof -
     have "H2_UR $$ (0,0) = H2 $$ (0,1)"
       by (smt A H2_H_Q_div_k H2_UL H2_as_four_block_mat H2_def H_P2_P1_A_Q1'_Q2' 
           Num.numeral_nat(7) P2_P1 Q2' add_diff_cancel_left' carrier_matD dim_col_A_g2 index_mat_addcol
           index_mat_four_block index_mult_mat less_trans_Suc plus_1_eq_Suc pos2 semiring_norm(138) 
           zero_less_one_class.zero_less_one)
     also have "... = H $$ (0,1)"
       unfolding H2_def by (rule index_mat_addcol, insert H A n_ge_2, auto) 
     also have "... = (P2 * D * Q2) $$ (0,1)"
       by (smt C_D_E C_P1_A_Q1' D H2_H_Q_div_k H2_UL H2_as_four_block_mat H_P2_P1_A_Q1'_Q2' H_def Q1' 
           Q2 add_lessD1 append_cols_def carrier_matD(1) carrier_matD(2) dim_col_A_g2 
           index_mat_four_block index_mult_mat(2) index_mult_mat(3) lessI numerals(2) plus_1_eq_Suc zero_less_Suc)
     also have "... = 0" using is_SNF_D P2D2Q2 D 
       unfolding is_SNF_def Smith_normal_form_mat_def isDiagonal_mat_def by auto
     finally show "H2_UR $$ (0,0) = 0" .
   qed
   have H2_UR_0j: "H2_UR $$ (0,j) = 0" if j_ge_1: "j > 1" and j: "j<n-1" for j
   proof -
    have col_E_0: "col E (j - 1) = 0v 2"
      by (rule eq_vecI, unfold col_def, insert E E_ij_0 j j_ge_1 n_ge_2, auto) 
        (metis E Suc_diff_Suc Suc_lessD Suc_less_eq Suc_pred carrier_matD index_vec numerals(2), insert E, blast)
    have "H2_UR $$ (0,j) = H2 $$ (0,j+1)"
      by (metis (no_types, lifting) A H2_P2_P1_A_Q1'_Q2'_Q_div_k H2_UL H2_as_four_block_mat H2_def 
          H_P2_P1_A_Q1'_Q2' P2_P1 Q2' add_diff_cancel_right' carrier_matD index_mat_addcol(5) 
          index_mat_four_block index_mult_mat(2,3) less_diff_conv less_numeral_extra(1) not_add_less2 pos2 j)
    also have "... = H $$ (0,j+1)" unfolding H2_def
      by (metis A H2_P2_P1_A_Q1'_Q2'_Q_div_k H2_def H_P2_P1_A_Q1'_Q2' One_nat_def P2_P1 Q_div_k_def 
          add_right_cancel carrier_matD(1) carrier_matD(2) index_mat_addcol(3) index_mat_addcol(5) 
          index_mat_addrow_mat(3) index_mult_mat(2) index_mult_mat(3) less_diff_conv less_not_refl2 
          numerals(2) plus_1_eq_Suc pos2 j j_ge_1)
    also have "... = (if j+1 < dim_col (P2 * D * Q2) 
      then (P2 * D * Q2) $$ (0, j+1) else (P2*E) $$ (0, (j+1) - 2))"
      by (unfold H_def, rule append_cols_nth, insert E P2 A Q2 D j, auto simp add: E_def)
    also have "... = (P2*E) $$ (0, j - 1)" 
      by (metis (no_types, lifting) D One_nat_def Q2 add_Suc_right add_lessD1 arithmetic_simps(50) 
          carrier_matD(2) diff_Suc_Suc index_mult_mat(3) not_less_eq numeral_2_eq_2 j_ge_1)
    also have "... = Matrix.row P2 0  col E (j - 1)" 
      by (rule index_mult_mat, insert P2 j_ge_1 A j, auto simp add: E_def)
    also have "... = 0" unfolding col_E_0 by (simp add: scalar_prod_def)
    finally show ?thesis .
  qed
  have H00_dvd_D01: "H$$(0,0) dvd D$$(0,1)"
  proof -
    have "H$$(0,0) = (P2*D*Q2) $$ (0,0)" unfolding H_def using append_cols_nth D E
      by (smt A C_D_E C_P1_A_Q1' D H2_DR H2_H_Q_div_k H2_UL H2_as_four_block_mat H_P2_P1_A_Q1'_Q2' 
          One_nat_def P1 Q1' Q2 Suc_lessD append_cols_def carrier_matD dim_col_A_g2 
          index_mat_four_block index_mult_mat numerals(2) plus_1_eq_Suc zero_less_Suc)
    also have "... dvd D$$(0,1)" by (rule S00_dvd_all_A[OF D _ _ inv_P2 inv_Q2],
          insert is_SNF_D P2D2Q2 P2 Q2 D, unfold is_SNF_def, auto)
    finally show ?thesis .    
  qed
  have D01_dvd_H02: "D$$(0,1) dvd H$$(0,2)" and D01_dvd_H12: "D$$(0,1) dvd H$$(1,2)"
  proof -
    have "D$$(0,1) = C$$(0,1)" unfolding C_D_E
      by (smt A C_D_E C_P1_A_Q1' D One_nat_def P1 Q1' append_cols_def carrier_matD(1) carrier_matD(2) 
          dim_col_A_g2 index_mat_four_block(1) index_mat_four_block(2) index_mat_four_block(3) 
          index_mult_mat(2) index_mult_mat(3) lessI less_trans_Suc numerals(2) pos2)
      also have "... = (P1*A2*Q1) $$ (0,0)" using C_def
        by (smt "1"(2) A1 A_A1_A2 P1 Q1 add_diff_cancel_left' append_cols_def card_num_simps(30) 
            carrier_matD dim_col_A_g2 index_mat_four_block index_mult_mat less_numeral_extra(4) 
            less_trans_Suc plus_1_eq_Suc pos2)
      also have "... dvd (P1*A2*Q1) $$ (1,1)"
        by (smt "1"(2) A2 One_nat_def P1 Q1 S00_dvd_all_A SNF_P1A2Q1 carrier_matD(1) carrier_matD(2) dim_col_A_g2 
            dvd_elements_mult_matrix_left_right inv_P1 inv_Q1 lessI less_diff_conv numeral_2_eq_2 plus_1_eq_Suc)
      also have "... = C $$ (1,2)" unfolding C_def
        by (smt "1"(2) A1 A_A1_A2 One_nat_def P1 Q1 append_cols_def carrier_matD(1) carrier_matD(2) diff_Suc_1 
            dim_col_A_g2 index_mat_four_block index_mult_mat lessI not_numeral_less_one numeral_2_eq_2)
      also have "... = E $$ (1,0)" unfolding C_D_E
        by (smt "1"(3) A C_D_E C_P1_A_Q1' D One_nat_def append_cols_def carrier_matD less_irrefl_nat
            P1 Q1' diff_Suc_1 diff_Suc_Suc index_mat_four_block index_mult_mat lessI  numerals(2))
      finally have *: "D$$(0,1) dvd E $$(1,0)" by auto
      also have "... dvd (P2*E)$$ (0,0)" 
        by (smt "1"(3) A E E_ij_0 P2 carrier_matD(1) carrier_matD(2) dvd_0_right 
            dvd_elements_mult_matrix_left dvd_refl pos2 zero_less_diff) 
      also have "... = H$$(0,2)" unfolding H_def
        by (smt "1"(3) A C_D_E C_P1_A_Q1' D Groups.add_ac(1) H2_DR H2_H_Q_div_k H2_UL H2_as_four_block_mat 
            H_P2_P1_A_Q1'_Q2' One_nat_def P1 Q1' Q2 add_diff_cancel_left' append_cols_def carrier_matD
             index_mat_four_block index_mult_mat less_irrefl_nat numerals(2) plus_1_eq_Suc pos2)
      finally show "D $$ (0, 1) dvd H $$ (0, 2)" .
      have "E $$(1,0) dvd (P2*E)$$ (1,0)"
        by (smt "1"(3) A E E_ij_0 P2 carrier_matD(1) carrier_matD(2) dvd_0_right 
            dvd_elements_mult_matrix_left dvd_refl rel_simps(49) semiring_norm(76) zero_less_diff)
      also have "... = H $$(1,2)" unfolding H_def
        by (smt A C_D_E C_P1_A_Q1' D H2_DR H2_H_Q_div_k H2_UL H2_as_four_block_mat H_P2_P1_A_Q1'_Q2' 
            One_nat_def P1 Q1' Q2 add_diff_cancel_left' append_cols_def carrier_matD diff_Suc_eq_diff_pred 
            index_mat_four_block index_mult_mat lessI less_irrefl_nat n_ge_2 numerals(2) plus_1_eq_Suc)
      finally show "D$$(0,1) dvd H$$(1,2)" using * by auto
    qed
    have kH00_eq_H02: "k * H $$ (0, 0) = H $$ (0, 2)" 
      using id D01_dvd_H02 H00_dvd_D01 unfolding k_def is_div_op_def by auto
    have H2_UR_01: "H2_UR $$ (0,1) = 0"
    proof -
      have "H2_UR $$ (0,1) = H2 $$ (0,2)"
        by (metis (no_types, lifting) A H2_P2_P1_A_Q1'_Q2'_Q_div_k H2_UL H2_as_four_block_mat One_nat_def 
            P2_P1 Q_div_k_def carrier_matD diff_Suc_1 dim_col_A_g2 index_mat_addrow_mat(3) 
            index_mat_four_block index_mult_mat(2,3) numeral_2_eq_2 pos2 rel_simps(50) rel_simps(68))
      also have "... = (-k) * H $$ (0, 0) + H $$ (0, 2)" 
        by (unfold H2_def, rule index_mat_addcol[of _ ], insert H A n_ge_2, auto)
      also have "... = 0" using kH00_eq_H02 by auto
      finally show ?thesis .
    qed   
   have H2_UR_0: "H2_UR = (0m 1 (n - 1))"
     by (rule eq_matI, insert H2_UR_0j H2_UR_01 H2_UR_00 H2_UR A nat_neq_iff, auto)
   have H2_UL_H: "H2_UL $$ (0,0) = H $$ (0,0)"
   proof -
     have "H2_UL $$ (0,0) = H2 $$ (0,0)"
       by (metis (no_types, lifting) Pair_inject index_mat(1) split_H2 split_block_def 
           zero_less_one_class.zero_less_one)
     also have "... = H $$ (0,0)" 
       unfolding H2_def by (rule index_mat_addcol, insert H A n_ge_2, auto) 
     finally show ?thesis .
   qed
   have H2_DL_H_10: "H2_DL $$ (0,0) = H$$(1,0)"
   proof -
     have "H2_DL $$ (0,0) = H2 $$ (1,0)"
       by (smt H2_DL One_nat_def Pair_inject add.right_neutral add_Suc_right carrier_matD(1) 
           dim_row_mat(1) index_mat(1) rel_simps(68) split_H2 split_block_def split_conv)
     also have "... = H$$(1,0)" unfolding H2_def by (rule index_mat_addcol, insert H A n_ge_2, auto) 
     finally show ?thesis .
   qed
   have H_10: "H $$(1,0) = 0"
   proof -
     have "H $$(1,0) = (P2 * D * Q2) $$ (1,0)" unfolding H_def
       by (smt A C_D_E C_P1_A_Q1' D E One_nat_def P1 P2_P1 Q2 Q2' Q2'_def Suc_lessD append_cols_def 
           carrier_matD dim_col_A_g2 index_mat_four_block index_mult_mat index_one_mat 
           index_zero_mat lessI numerals(2))
     also have "... = 0" using is_SNF_D P2D2Q2 D 
       unfolding is_SNF_def Smith_normal_form_mat_def isDiagonal_mat_def by auto
     finally show ?thesis .
   qed
   have S_H2_Q3': "S = H2 * Q3'" 
     and S_as_four_block_mat: "S = four_block_mat (H2_UL) (0m 1 (n - 1)) (H2_DL) (H2_DR * Q3)"
   proof -
     have "H2 * Q3' = four_block_mat (H2_UL * 1m 1 + H2_UR * 0m (dim_col A - 1) 1) 
     (H2_UL * 0m 1 (dim_col A - 1) + H2_UR * Q3)
     (H2_DL * 1m 1 + H2_DR * 0m (dim_col A - 1) 1) (H2_DL * 0m 1 (dim_col A - 1) + H2_DR * Q3)"
       unfolding H2_as_four_block_mat Q3'_def 
       by (rule mult_four_block_mat[OF H2_UL H2_UR H2_DL H2_DR], insert Q3 A H', auto)
     also have "... = four_block_mat (H2_UL) (0m 1 (n - 1)) (H2_DL) (H2_DR * Q3)"
       by (rule cong_four_block_mat, insert H2_UR_0 H2_UL H2_UR H2_DL H2_DR Q3, auto)
     also have *: "... = S" unfolding S_def 
     proof (rule cong_four_block_mat)
       show "H2_UL = Matrix.mat 1 1 (λ(a, b). H $$ (0, 0))" 
         by (rule eq_matI, insert H2_UL H2_UL_H, auto)
       show "H2_DR * Q3 = H_1xn" using is_SNF_H' unfolding is_SNF_def by auto
       show "0m 1 (n - 1) = 0m 1 (dim_col A - 1)" using A by auto
       show "H2_DL = 0m 1 1" using H2_DL H2_DL_H_10 H_10 by auto
     qed
     finally show "S = H2 * Q3'" 
       and "S = four_block_mat (H2_UL) (0m 1 (n - 1)) (H2_DL) (H2_DR * Q3)"
       using * by auto
   qed
   thus "S = P2 * P1 * A * (Q1' * Q2' * Q_div_k * Q3')" unfolding H2_P2_P1_A_Q1'_Q2'_Q_div_k     
     by (smt Q1' Q2' Q2'_def Q3' Q3'_def Q_div_k assoc_mult_mat 
         carrier_matD carrier_mat_triv index_mult_mat)
   show "Smith_normal_form_mat S"
   proof (rule Smith_normal_form_mat_intro)
     have Sij_0: "S$$(i,j) = 0" if ij: "i  j" and i: "i < dim_row S" and j: "j < dim_col S" for i j
     proof (cases "i=1  j=0")
       case True
       have "S$$(1,0) = 0" using S_as_four_block_mat
         by (metis (no_types, lifting) H2_DL_H_10 H2_UL H_10 One_nat_def True carrier_matD diff_Suc_1 
             index_mat_four_block rel_simps(71) that(2) that(3) zero_less_one_class.zero_less_one)
       then show ?thesis using True by auto
      next
        case False note not_10 = False
        show ?thesis
        proof (cases "i=0")
          case True
          hence j0: "j>0" using ij by auto
          then show ?thesis using S_as_four_block_mat
            by (smt "1"(2) H2_DR H2_H_Q_div_k H2_UL H_P2_P1_A_Q1'_Q2' Num.numeral_nat(7) P2_P1 Q3 S_H2_Q3'
                Suc_pred True carrier_matD index_mat_four_block index_mult_mat index_zero_mat(1)
                not_less_eq plus_1_eq_Suc pos2 that(3) zero_less_one_class.zero_less_one)
        next
          case False
          have SNF_H_1xn: "Smith_normal_form_mat H_1xn" using is_SNF_H' unfolding is_SNF_def by auto 
          have i1: "i=1" using False ij i H2_DR H2_UL S_as_four_block_mat by auto
          hence j1: "j>1" using ij not_10 by auto thm is_SNF_H'
          have "S$$(i,j) = (if i < dim_row H2_UL then if j < dim_col H2_UL then H2_UL $$ (i, j) 
            else (0m 1 (n - 1)) $$ (i, j - dim_col H2_UL)
            else if j < dim_col H2_UL then H2_DL $$ (i - dim_row H2_UL, j) 
            else (H2_DR * Q3) $$ (i - dim_row H2_UL, j - dim_col H2_UL))"
            unfolding S_as_four_block_mat 
            by (rule index_mat_four_block, insert i j H2_UL H2_DR Q3 S_H2_Q3' H2 Q3' A, auto)
          also have "... = (H2_DR * Q3) $$ (0, j - 1)" using H2_UL i1 not_10 by auto
          also have "... = H_1xn $$ (0,j-1)"
            using S_def calculation i1 j not_10 i by auto           
          also have "... = 0" using SNF_H_1xn j1 i j
            unfolding Smith_normal_form_mat_def isDiagonal_mat_def
            by (simp add: S_def i1)
          finally show ?thesis .
        qed
      qed
      thus "isDiagonal_mat S" unfolding isDiagonal_mat_def by auto
      have "S$$(0,0) dvd S$$(1,1)"
      proof -       
        have dvd_all: "i j. i < 2  j < n  H2_UL$$(0,0) dvd (H2 * Q3') $$ (i, j)"
        proof (rule dvd_elements_mult_matrix_right)
          show H2': "H2  carrier_mat 2 n" using H2 A by auto
          show "Q3'  carrier_mat n n" using Q3' A by auto
          have "H2_UL $$ (0, 0) dvd H2 $$ (i, j)" if i: "i < 2" and j: "j < n"  for i j
          proof (cases "i=0")
            case True
            then show ?thesis
              by (metis (no_types, lifting) A H2_H_Q_div_k H2_UL H2_UR_0 H2_as_four_block_mat 
                  H_P2_P1_A_Q1'_Q2' P2_P1 Q3 Q_div_k S_as_four_block_mat Sij_0 carrier_matD 
                  dvd_0_right dvd_refl index_mat_four_block index_mult_mat(2,3) j less_one pos2)
          next
            case False
            hence i1: "i=1" using i by auto
            have H2_10_0: "H2 $$ (1,0) = 0"
              by (metis (no_types, lifting) H2_H_Q_div_k H2_def H_10 H_P2_P1_A_Q1'_Q2' One_nat_def 
                  Q2' H2' basic_trans_rules(19) carrier_matD dim_col_A_g2 index_mat_addcol(3)
                  index_mult_mat(2,3) lessI numeral_2_eq_2 rel_simps(76))            
            moreover have H2_UL00_dvd_H211:"H2_UL $$ (0, 0) dvd H2 $$ (1, 1)"
            proof - 
              have "H2_UL $$ (0, 0) = H $$ (0, 0)" by (simp add: H2_UL_H)
              also have "... = (P2*D*Q2) $$ (0,0)" unfolding H_def using append_cols_nth D E
                by (smt A C_D_E C_P1_A_Q1' D H2_DR H2_H_Q_div_k H2_UL H2_as_four_block_mat 
                    H_P2_P1_A_Q1'_Q2' One_nat_def P1 Q1' Q2 Suc_lessD append_cols_def carrier_matD 
                    dim_col_A_g2 index_mat_four_block index_mult_mat numerals(2) plus_1_eq_Suc zero_less_Suc)
              also have "... dvd (P2*D*Q2) $$ (1,1)" 
                using is_SNF_D P2D2Q2 unfolding is_SNF_def Smith_normal_form_mat_def by auto 
                (metis D Q2 carrier_matD index_mult_mat(1) index_mult_mat(2) lessI numerals(2) pos2)
              also have "... = H $$ (1,1)" unfolding H_def using append_cols_nth D E
                by (smt A C_D_E C_P1_A_Q1' H2_DR H2_H_Q_div_k H2_UL H2_as_four_block_mat H_P2_P1_A_Q1'_Q2' 
                    One_nat_def P1 Q1' Q2 append_cols_def carrier_matD(1) carrier_matD(2) dim_col_A_g2 
                    index_mat_four_block index_mult_mat(2) index_mult_mat(3) lessI less_trans_Suc 
                    numerals(2) plus_1_eq_Suc pos2)
              also have "... = H2 $$ (1, 1)" 
                by (metis A H2_def H_P2_P1_A_Q1'_Q2' One_nat_def P2_P1 Q2' carrier_matD dim_col_A_g2 i i1 
                    index_mat_addcol(3) index_mult_mat(2) index_mult_mat(3) less_trans_Suc nat_neq_iff pos2)
              finally show ?thesis .
            qed
            moreover have H2_UL00_dvd_H212: "H2_UL $$ (0, 0) dvd H2 $$ (1, 2)"
            proof -            
              have "H2_UL $$ (0, 0) = H $$ (0, 0)" by (simp add: H2_UL_H)
              also have "... dvd H $$ (1,2)" using D01_dvd_H12 H00_dvd_D01 dvd_trans by blast
              also have "... = (-k) * H $$ (1,0) + H $$ (1,2)"
                using H_10 by auto
              also have "... = H2 $$ (1,2)" 
                unfolding H2_def by (rule index_mat_addcol[symmetric], insert H A n_ge_2, auto)
              finally show ?thesis .
            qed
            moreover have "H2 $$ (1, j) = 0" if j1: "j>2" and j: "j<n"
            proof -
              let ?f = "(λ(i, j). ia = 0..<dim_vec (col E j). Matrix.row P2 i $v ia * col E j $v ia)"
              have "H2 $$ (1, j) = H $$ (1,j)" unfolding H2_def using j j1 n_ge_2 
                by (metis (mono_tags, lifting) "1"(2) H2' H_10 H_P2_P1_A_Q1'_Q2' Q2' arithmetic_simps(49) 
                    carrier_matD i i1 index_mat_addcol(1) index_mult_mat semiring_norm(64) H2_H_Q_div_k)
              also have "... = (P2*E)$$ (1,j-2)" unfolding H_def
                by (smt A C_D_E C_P1_A_Q1' D H2' H2_H_Q_div_k H_P2_P1_A_Q1'_Q2' P1 Q1' Q2 append_cols_def 
                    basic_trans_rules(19) carrier_matD index_mat_four_block index_mult_mat(2) 
                    index_mult_mat(3) j less_one nat_neq_iff not_less_less_Suc_eq numerals(2) j1)
              also have "... =  Matrix.mat (dim_row P2) (dim_col E) ?f $$ (1, j - 2)"
                unfolding times_mat_def scalar_prod_def by simp 
              also have "... = ?f (1,j-2)" by (rule index_mat, insert P2 E E_def n_ge_2 j j1 A, auto)              
              also have "... = (ia = 0..<2. Matrix.row P2 1 $v ia * col E (j-2) $v ia)" 
                using E A E_def j j1 by auto
              also have "... = (ia  {0,1}. Matrix.row P2 1 $v ia * col E (j-2) $v ia)" 
                by (rule sum.cong, auto)
              also have "... = Matrix.row P2 1 $v 0 * col E (j - 2) $v 0 
                    + Matrix.row P2 1 $v 1 * col E (j - 2) $v 1" 
                by (simp add: sum_two_elements[OF zero_neq_one])
              also have "... = 0" using E_ij_0 E_def E A
                by (auto, smt D Q2 Q2' Q2'_def Suc_lessD add_cancel_right_right add_diff_inverse_nat 
                    arith_extra_simps(19) carrier_matD i i1 index_col index_mat_four_block(3) 
                    index_one_mat(3) less_2_cases nat_add_left_cancel_less numeral_2_eq_2 
                    semiring_norm(138) semiring_norm(160) j j1 zero_less_diff)                
              finally show ?thesis .
            qed
            ultimately show ?thesis using i1 False
              by (metis One_nat_def dvd_0_right less_2_cases nat_neq_iff j)
          qed                      
          thus "i j. i < 2  j < n  H2_UL $$ (0, 0) dvd H2 $$ (i, j)" by auto
        qed
        have "S$$(0,0) = H2_UL $$ (0,0)" using H2_UL S_as_four_block_mat by auto
        also have "... dvd (H2*Q3') $$ (1,1)" using dvd_all n_ge_2 by auto
        also have "... = S $$ (1,1)" using S_H2_Q3' by auto
        finally show ?thesis .       
      qed
      thus "a. a + 1 < min (dim_row S) (dim_col S)  S $$ (a, a) dvd S $$ (a + 1, a + 1)"
        by (metis "1"(2) H2_H_Q_div_k H_P2_P1_A_Q1'_Q2' One_nat_def P2_P1 S_H2_Q3' Suc_eq_plus1
            index_mult_mat(2) less_Suc_eq less_one min_less_iff_conj numeral_2_eq_2 carrier_matD(1))
    qed
  qed
qed


lemma is_SNF_Smith_2xn: 
  assumes A: "A  carrier_mat 2 n"
  shows "is_SNF A (Smith_2xn A)"
proof (cases "n>2")
  case True
  then show ?thesis using is_SNF_Smith_2xn_n_ge_2[OF A] by simp
next
  case False
  hence "n=0  n=1  n=2" by auto
  then show ?thesis using Smith_2xn_0 Smith_2xn_1 Smith_2xn_2 A by blast
qed

subsubsection ‹Case $n \times 2$›

definition "Smith_nx2 A = (let (P,S,Q) = Smith_2xn AT in
   (QT, ST, PT))"

lemma is_SNF_Smith_nx2: 
  assumes A: "A  carrier_mat n 2"
  shows "is_SNF A (Smith_nx2 A)"
proof -
  obtain P S Q where PSQ: "(P,S,Q) = Smith_2xn AT" by (metis prod_cases3)
  hence rw: "Smith_nx2 A = (QT, ST, PT)" unfolding Smith_nx2_def by (metis split_conv)
  have "is_SNF AT (Smith_2xn AT)" by (rule is_SNF_Smith_2xn, insert id A, auto)
  hence is_SNF_PSQ: "is_SNF AT (P,S,Q)" using PSQ by auto
  show ?thesis
  proof (unfold rw, rule is_SNF_intro)
    show Qt: "QT  carrier_mat (dim_row A) (dim_row A)"
      and Pt: "PT  carrier_mat (dim_col A) (dim_col A)"
      and "invertible_mat QT" and "invertible_mat PT"
      using is_SNF_PSQ invertible_mat_transpose unfolding is_SNF_def by auto
    have "Smith_normal_form_mat S" and PATQ: "S =  P * AT * Q"
      using is_SNF_PSQ invertible_mat_transpose unfolding is_SNF_def by auto
    thus "Smith_normal_form_mat ST" unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto
    show "ST = QT * A * PT" using PATQ
      by (smt Matrix.transpose_mult Matrix.transpose_transpose Pt Qt assoc_mult_mat
          carrier_mat_triv index_mult_mat(2))
  qed
qed

subsubsection ‹Case $m \times n$›

(*This is necessary to avoid a loop with domintros*)
declare Smith_2xn.simps[simp del]

function (domintros) Smith_mxn :: "'a mat  ('a mat × 'a mat × 'a mat)"
  where
    "Smith_mxn A = (
  if dim_row A = 0  dim_col A = 0 then (1m (dim_row A),A,1m (dim_col A))
  else if dim_row A = 1 then (1m 1, Smith_1xn A) 
  else if dim_row A = 2 then Smith_2xn A
  else if dim_col A = 1 then let (P,S) = Smith_nx1 A in (P,S,1m 1)
  else if dim_col A = 2 then Smith_nx2 A
  else
  let A1 = mat_of_row (Matrix.row A 0);
      A2 = mat_of_rows (dim_col A) [Matrix.row A i. i  [1..<dim_row A]];
      (P1,D1,Q1) = Smith_mxn A2;
      C = (A1*Q1) @r (P1*A2*Q1);
      D = mat_of_rows (dim_col A) [Matrix.row C 0, Matrix.row C 1];
      E = mat_of_rows (dim_col A) [Matrix.row C i. i  [2..<dim_row A]];
      (P2,F,Q2) = Smith_2xn D;
      H = (P2*D*Q2) @r (E*Q2);
      (P_H2, H2) = reduce_column div_op H;
      (H2_UL, H2_UR, H2_DL, H2_DR) = split_block H2 1 1;
      (P3,S',Q3) = Smith_mxn H2_DR;
      S = four_block_mat (Matrix.mat 1 1 (λ(a, b). H $$ (0, 0))) (0m 1 (dim_col A - 1)) (0m (dim_row A - 1) 1) S';
      P1' = four_block_mat (1m 1) (0m 1 (dim_row A - 1)) (0m (dim_row A - 1) 1) P1;
      P2' = four_block_mat P2 (0m 2 (dim_row A - 2)) (0m (dim_row A - 2) 2) (1m (dim_row A - 2));
      P3' = four_block_mat (1m 1) (0m 1 (dim_row A - 1)) (0m (dim_row A - 1) 1) P3;
      Q3' = four_block_mat (1m 1) (0m 1 (dim_col A - 1)) (0m (dim_col A - 1) 1) Q3
  in (P3' * P_H2 * P2' * P1',S, Q1 * Q2 * Q3')
)"
  by pat_completeness fast
(*Termination is guaranteed since the algorithm is recursively applied to a 
  submatrix with less rows*)


(*Now I introduce it again*)
declare Smith_2xn.simps[simp]

lemma Smith_mxn_dom_nm_less_2: 
  assumes A: "A  carrier_mat m n" and mn: "n2  m2"
  shows "Smith_mxn_dom A"
  by (rule Smith_mxn.domintros, insert assms, auto) (*Takes a while*)

lemma Smith_mxn_pinduct_carrier_less_2: 
  assumes A: "A  carrier_mat m n" and mn: "n2  m2"
  shows "fst (Smith_mxn A)  carrier_mat m m 
   fst (snd (Smith_mxn A))  carrier_mat m n
   snd (snd (Smith_mxn A))  carrier_mat n n"
proof -
  have A_dom: "Smith_mxn_dom A" using Smith_mxn_dom_nm_less_2[OF assms] by simp
  show ?thesis
proof (cases "dim_row A = 0  dim_col A = 0")
  case True
  have "Smith_mxn A = (1m (dim_row A),A,1m (dim_col A))"
    using Smith_mxn.psimps[OF A_dom] True by auto
  thus ?thesis using A by auto        
next
  case False note 1 = False
  show ?thesis
  proof (cases "dim_row A = 1")
    case True
    have "Smith_mxn A = (1m 1, Smith_1xn A)"
      using Smith_mxn.psimps[OF A_dom] True 1 by auto
    then show ?thesis using Smith_1xn_works unfolding is_SNF_def
      by (smt Smith_1xn_aux_Q_carrier Smith_1xn_aux_S'_AQ' Smith_1xn_def True assms(1) carrier_matD 
          carrier_matI diff_less fst_conv index_mult_mat not_gr0 one_carrier_mat prod.collapse 
          right_mult_one_mat' snd_conv zero_less_one_class.zero_less_one)
  next
    case False note 2 = False
    then show ?thesis 
    proof (cases "dim_row A = 2")
      case True
      hence A': "A  carrier_mat 2 n" using A by auto
      have "Smith_mxn A = Smith_2xn A" using Smith_mxn.psimps[OF A_dom] True 1 2 by auto
      then show ?thesis using is_SNF_Smith_2xn[OF A'] A unfolding is_SNF_def
        by (metis (mono_tags, lifting) carrier_matD carrier_mat_triv case_prod_beta index_mult_mat(2,3))
    next
      case False note 3 = False
      show ?thesis 
      proof (cases "dim_col A = 1")
        case True
        hence A': "A  carrier_mat m 1" using A by auto
        have "Smith_mxn A = (let (P,S) = Smith_nx1 A in (P,S,1m 1))" 
          using Smith_mxn.psimps[OF A_dom] True 1 2 3 by auto
        then show ?thesis using Smith_nx1_works[OF A'] A unfolding is_SNF_def
          by (metis (mono_tags, lifting) carrier_matD carrier_mat_triv case_prod_unfold 
              index_mult_mat(2,3) surjective_pairing)
      next
        case False
        hence "dim_col A = 2" using 1 2 3 mn A by auto
        hence A': "A  carrier_mat m 2" using A by auto
        hence "Smith_mxn A = Smith_nx2 A" 
          using Smith_mxn.psimps[OF A_dom] 1 2 3 False by auto
        then show ?thesis using is_SNF_Smith_nx2[OF A'] A unfolding is_SNF_def by force
      qed
    qed  
  qed
qed
qed

lemma Smith_mxn_pinduct_carrier_ge_2: "Smith_mxn_dom A; A  carrier_mat m n; m>2; n>2  
    fst (Smith_mxn A)  carrier_mat m m 
   fst (snd (Smith_mxn A))  carrier_mat m n
   snd (snd (Smith_mxn A))  carrier_mat n n"
proof (induct arbitrary: m n rule: Smith_mxn.pinduct)
  case (1 A)
  note A_dom = 1(1)
  note A = "1.prems"(1)
  note m = "1.prems"(2)
  note n = "1.prems"(3)  
  define A1 where "A1 = mat_of_row (Matrix.row A 0)"
  define A2 where "A2 = mat_of_rows (dim_col A) [Matrix.row A i. i  [1..<dim_row A]]"
  obtain P1 D1 Q1 where P1D1Q1: "(P1,D1,Q1) = Smith_mxn A2" by (metis prod_cases3)
  define C where "C = (A1*Q1) @r (P1*A2*Q1)"
  define D where "D = mat_of_rows (dim_col A) [Matrix.row C 0, Matrix.row C 1]"
  define E where "E = mat_of_rows (dim_col A) [Matrix.row C i. i  [2..<dim_row A]]"
  obtain P2 F Q2 where P2FQ2: "(P2,F,Q2) = Smith_2xn D" by (metis prod_cases3)
  define H where "H = (P2*D*Q2) @r (E*Q2)"
  obtain P_H2 H2 where P_H2H2: "(P_H2, H2) = reduce_column div_op H" by (metis surj_pair)
  obtain H2_UL H2_UR H2_DL H2_DR where split_H2: "(H2_UL, H2_UR, H2_DL, H2_DR) = split_block H2 1 1"
    by (metis split_block_def)
  obtain P3 S' Q3 where P3S'Q3: "(P3,S',Q3) = Smith_mxn H2_DR" by (metis prod_cases3)
  define S where "S = four_block_mat (Matrix.mat 1 1 (λ(a, b). H $$ (0, 0))) (0m 1 (dim_col A - 1))
    (0m (dim_row A - 1) 1) S'"
  define P1' where "P1' = four_block_mat (1m 1) (0m 1 (dim_row A - 1)) (0m (dim_row A - 1) 1) P1"
  define P2' where "P2' = four_block_mat P2 (0m 2 (dim_row A - 2)) (0m (dim_row A - 2) 2) (1m (dim_row A - 2))"
  define P3' where "P3' = four_block_mat (1m 1) (0m 1 (dim_row A - 1)) (0m (dim_row A - 1) 1) P3"
  define Q3' where "Q3' = four_block_mat (1m 1) (0m 1 (dim_col A - 1)) (0m (dim_col A - 1) 1) Q3"
  have A1: "A1  carrier_mat 1 n" unfolding A1_def using A by auto
  have A2: "A2  carrier_mat (m-1) n" unfolding A2_def using A by auto
  have "fst (Smith_mxn A2)  carrier_mat (m-1) (m-1)
   fst (snd (Smith_mxn A2))  carrier_mat (m-1) n
   snd (snd (Smith_mxn A2))  carrier_mat n n"
  proof (cases "2 < m - 1")
    case True
    show ?thesis by (rule "1.hyps"(2), insert A m n A2_def A1_def True id, auto)    
  next
    case False
    hence "m=3" using m by auto
    hence A2': "A2  carrier_mat 2 n" using A2 by auto
    have A2_dom: "Smith_mxn_dom A2" by (rule Smith_mxn.domintros, insert A2', auto)    
    have "dim_row A2 = 2" using A2 A2' by fast
    hence "Smith_mxn A2 = Smith_2xn A2" 
      using n unfolding Smith_mxn.psimps[OF A2_dom] by auto
    then show ?thesis using is_SNF_Smith_2xn[OF A2'] m A2 unfolding is_SNF_def split_beta
      by (metis carrier_matD carrier_matI index_mult_mat(2,3))
  qed
  hence P1: "P1  carrier_mat (m-1) (m-1)" 
    and D1: "D1  carrier_mat (m-1) n" 
    and Q1: "Q1  carrier_mat n n" using P1D1Q1 by (metis fst_conv snd_conv)+
  have "C  carrier_mat (1 + (m-1)) n" unfolding C_def 
    by (rule carrier_append_rows, insert P1 D1 Q1 A1, auto)
  hence C: "C  carrier_mat m n" using m by simp
  have D: "D  carrier_mat 2 n" unfolding D_def using C A by auto
  have E: "E  carrier_mat (m-2) n" unfolding E_def using A by auto
  have P2: "P2  carrier_mat 2 2" and Q2: "Q2  carrier_mat n n" 
    using is_SNF_Smith_2xn[OF D] P2FQ2 D unfolding is_SNF_def by auto
  have "H  carrier_mat (2 + (m-2)) n" unfolding H_def 
    by (rule carrier_append_rows, insert P2 D Q2 E, auto)
  hence H: "H  carrier_mat m n" using m by auto
  have H2: "H2  carrier_mat m n" using m H P_H2H2 reduce_column by blast
  have H2_DR: "H2_DR  carrier_mat (m - 1) (n - 1)"
    by (rule split_block(4)[OF split_H2[symmetric]], insert H2 m n, auto)
  have "fst (Smith_mxn H2_DR)  carrier_mat (m-1) (m-1)
   fst (snd (Smith_mxn H2_DR))  carrier_mat (m-1) (n-1)
   snd (snd (Smith_mxn H2_DR))  carrier_mat (n-1) (n-1)"
  proof (cases "2<m-1  2<n-1")
    case True
    show ?thesis
    proof (rule "1.hyps"(3)[OF _ _ _ _ _ A1_def A2_def P1D1Q1 _ _ C_def])
      show "(P2,F,Q2) = Smith_2xn D" using P2FQ2 by auto
    qed (insert A P1D1Q1 D_def E_def P2FQ2 P_H2H2 P3S'Q3 H_def split_H2 H2_DR True id, auto)
  next
    case False note m_eq_3_or_n_eq_3 = False
    show ?thesis 
    proof (cases "(2 < m - 1)")
      case True
      hence n3: "n=3" using m_eq_3_or_n_eq_3 n m by auto
      have H2_DR_dom: "Smith_mxn_dom H2_DR"
        by (rule Smith_mxn.domintros, insert H2_DR n3, auto)
      have H2_DR': "H2_DR  carrier_mat (m-1) 2" using H2_DR n3 by auto
      hence "dim_col H2_DR = 2" by simp
      hence "Smith_mxn H2_DR = Smith_nx2 H2_DR" 
        using n H2_DR' True unfolding Smith_mxn.psimps[OF H2_DR_dom] by auto
      then show ?thesis using is_SNF_Smith_nx2[OF H2_DR'] m H2_DR unfolding is_SNF_def by auto
    next
      case False
      hence m3: "m=3" using m_eq_3_or_n_eq_3 n m by auto
      have H2_DR_dom: "Smith_mxn_dom H2_DR"
        by (rule Smith_mxn.domintros, insert H2_DR m3, auto)
      have H2_DR': "H2_DR  carrier_mat 2 (n-1)" using H2_DR m3 by auto
      hence "dim_row H2_DR = 2" by simp
      hence "Smith_mxn H2_DR = Smith_2xn H2_DR" 
        using n H2_DR' unfolding Smith_mxn.psimps[OF H2_DR_dom] by auto
      then show ?thesis using is_SNF_Smith_2xn[OF H2_DR'] m H2_DR unfolding is_SNF_def by force
    qed
  qed
  hence P3: "P3  carrier_mat (m-1) (m-1)"
  and S': "S' carrier_mat (m-1) (n-1)"
  and Q3: "Q3  carrier_mat (n-1) (n-1)" using P3S'Q3 by (metis fst_conv snd_conv)+
  have Smith_final: "Smith_mxn A = (P3' * P_H2 * P2' * P1', S, Q1 * Q2 * Q3')"
  proof -
    have P1_def: "P1 = fst (Smith_mxn A2)" and D1_def: "D1 = fst (snd (Smith_mxn A2))" 
      and Q1_def: "Q1 = snd (snd (Smith_mxn A2))" using P1D1Q1 by (metis fstI sndI)+
    have P2_def: "P2 = fst (Smith_2xn D)" and F_def: "F = fst (snd (Smith_2xn D))" 
      and Q2_def: "Q2 = snd (snd (Smith_2xn D))" using P2FQ2 by (metis fstI sndI)+
    have P_H2_def: "P_H2 = fst (reduce_column div_op H)" 
      and H2_def: "H2 = snd (reduce_column div_op H)" 
      using P_H2H2 by (metis fstI sndI)+
    have H2_UL_def: "H2_UL = fst (split_block H2 1 1)" 
      and H2_UR_def: "H2_UR = fst (snd (split_block H2 1 1))" 
      and H2_DL_def: "H2_DL = fst (snd (snd (split_block H2 1 1)))" 
      and H2_DR_def: "H2_DR = snd (snd (snd (split_block H2 1 1)))"
      using split_H2 by (metis fstI sndI)+
    have P3_def: "P3 = fst (Smith_mxn H2_DR)"
      and S'_def: "S' = fst (snd (Smith_mxn H2_DR))" 
      and Q3_def: "Q3 = (snd (snd (Smith_mxn H2_DR)))" using P3S'Q3 by (metis fstI sndI)+
    note aux = Smith_mxn.psimps[OF A_dom] Let_def split_beta
     A1_def[symmetric] A2_def[symmetric] P1_def[symmetric] D1_def[symmetric] Q1_def[symmetric]
     C_def[symmetric] D_def[symmetric] E_def[symmetric] P2_def[symmetric] Q2_def[symmetric]
     F_def[symmetric] H_def[symmetric] P_H2_def[symmetric] H2_def[symmetric] H2_UL_def[symmetric]
     H2_DL_def[symmetric] H2_UR_def[symmetric] H2_DR_def[symmetric] P3_def[symmetric] S'_def[symmetric]
     Q3_def[symmetric] P1'_def[symmetric] P2'_def[symmetric] P3'_def[symmetric] Q1_def[symmetric]
     Q2_def[symmetric] Q3'_def[symmetric] S_def[symmetric]
    show ?thesis by (rule prod3_intro, unfold aux, insert "1.prems", auto)
  qed
  have P1': "P1'  carrier_mat m m" unfolding P1'_def using P1 m by auto
  moreover have P2': "P2'  carrier_mat m m" unfolding P2'_def using P2 m A by auto
  moreover have P3': "P3'  carrier_mat m m" unfolding P3'_def using P3 m by auto
  moreover have P_H2: "P_H2  carrier_mat m m" using reduce_column[OF H P_H2H2] m by simp
  moreover have "S  carrier_mat m n" unfolding S_def using H A S'
    by (auto, smt C One_nat_def Suc_pred C  carrier_mat (1 + (m - 1)) n carrier_matD carrier_matI 
        dim_col_mat(1) dim_row_mat(1) index_mat_four_block n neq0_conv plus_1_eq_Suc zero_order(3))
  moreover have "Q3'  carrier_mat n n" unfolding Q3'_def using Q3 n by auto
  ultimately show ?case using Smith_final Q1 Q2 by auto
qed


corollary Smith_mxn_pinduct_carrier: "Smith_mxn_dom A; A  carrier_mat m n  
    fst (Smith_mxn A)  carrier_mat m m 
   fst (snd (Smith_mxn A))  carrier_mat m n
   snd (snd (Smith_mxn A))  carrier_mat n n"
  using Smith_mxn_pinduct_carrier_ge_2 Smith_mxn_pinduct_carrier_less_2
  by (meson linorder_not_le)


termination proof (relation "measure (λA. dim_row A)")
  fix A A1 A2 xb P1 y D1 Q1 C D E xf P2 yb Q2 F yc H xj P_H2 H2 xl xm ye xn yf xo yg
  assume 1: "¬ (dim_row A = 0  dim_col A = 0)" and 2: "dim_row A  1"
    and 3: "dim_row A  2" and 4: "dim_col A  1" and 5: "dim_col A  2"
    and 6: "A1 = mat_of_row (Matrix.row A 0)"
    and xa_def: "A2 = mat_of_rows (dim_col A) (map (Matrix.row A) [1..<dim_row A])"
    and xb_def: "xb = Smith_mxn A2" and P1_y_xb: "(P1, y) = xb "
    and D1_Q1_y: "(D1, Q1) = y " and C_def: "C = A1 * Q1 @r P1* A2 * Q1 "
    and D_def: "D = mat_of_rows (dim_col A) [Matrix.row C 0, Matrix.row C 1] "
    and E_def: "E = mat_of_rows (dim_col A) (map (Matrix.row C) [2..<dim_row A]) "
    and xf: "xf = Smith_2xn D" and P2_yb_xf: "(P2, yb) = xf" and F_Q2_yb: "(F, Q2) = yb "
    and H_def: "H = P2 * D * Q2 @r E * Q2 " and xj: "xj = reduce_column div_op H "
    and P_H2_H2: "(P_H2, H2) = xj" and b4: "xl = split_block H2 1 1 "
    and b1: "(xm, ye) = xl" and b2: "(xn, yf) = ye" and b3: "(xo, yg) = yf" 
    and A2_dom: "Smith_mxn_dom A2" 
  let ?m = "dim_row A"
  let ?n = "dim_col A"
  have m: "2< ?m" and n: "2 < ?n" using 1 2 3 4 5 6 by auto  
  have A1: "A1  carrier_mat 1 (dim_col A)" using 6 by auto
  have A2: "A2  carrier_mat (dim_row A - 1) (dim_col A)" using xa_def by auto
  have "fst (Smith_mxn A2)  carrier_mat (?m-1) (?m-1) 
         fst (snd (Smith_mxn A2))  carrier_mat (?m-1) ?n
         snd (snd (Smith_mxn A2))  carrier_mat ?n ?n" 
    by (rule Smith_mxn_pinduct_carrier[OF A2_dom A2])
  hence P1: "P1 carrier_mat (?m-1) (?m-1)"and D1: "D1  carrier_mat (?m-1) ?n"
    and Q1: "Q1  carrier_mat ?n ?n" using P1_y_xb D1_Q1_y xa_def xb_def by (metis fstI sndI)+
  have C: "C  carrier_mat ?m ?n" unfolding C_def using A1 Q1 P1 A2 Q1 
    by (smt 1 Suc_pred card_num_simps(30) carrier_append_rows mult_carrier_mat neq0_conv plus_1_eq_Suc)
  have D: "D  carrier_mat 2 ?n" unfolding D_def using C by auto
  have E: "E  carrier_mat (?m-2) ?n" unfolding E_def using C m by auto
  have P2FQ2: "(P2,F,Q2) = Smith_2xn D" using F_Q2_yb P2_yb_xf xf by blast
  have P2: "P2carrier_mat 2 2" and F: "F  carrier_mat 2 ?n" and Q2: "Q2  carrier_mat ?n ?n"
    using is_SNF_Smith_2xn[OF D] D P2FQ2 unfolding is_SNF_def by auto
  have "H  carrier_mat (2 + (?m-2)) ?n" 
    by (unfold H_def, rule carrier_append_rows, insert D Q2 P2 E, auto)
  hence H: "H  carrier_mat ?m ?n" using m by auto
  have H2: "H2  carrier_mat (dim_row H) (dim_col H)" 
    and P_H2: "P_H2  carrier_mat (dim_row A) (dim_row A)"
    using reduce_column[OF H xj[unfolded P_H2_H2[symmetric]]] m H by auto    
  have "dim_row yg < dim_row H2"      
    by (rule split_block4_decreases_dim_row, insert b1 b2 b3 b4 m n H H2, auto)
  also have "... = dim_row A" using H2 H by auto
  finally show "(yg, A)  measure dim_row" unfolding in_measure .
qed (auto)


lemma is_SNF_Smith_mxn_less_2: 
  assumes A: "A  carrier_mat m n" and mn: "n2  m2"
  shows "is_SNF A (Smith_mxn A)"
proof -
  show ?thesis
  proof (cases "dim_row A = 0  dim_col A = 0")
    case True
    have "Smith_mxn A = (1m (dim_row A),A,1m (dim_col A))"
      using Smith_mxn.simps True by auto
    thus ?thesis using A True unfolding is_SNF_def by auto
  next
    case False note 1 = False
    show ?thesis
    proof (cases "dim_row A = 1")
      case True
      have "Smith_mxn A = (1m 1, Smith_1xn A)"
        using Smith_mxn.simps True 1 by auto
      then show ?thesis using Smith_1xn_works by (metis True carrier_mat_triv surj_pair)
    next
      case False note 2 = False
      then show ?thesis 
      proof (cases "dim_row A = 2")
        case True
        hence A': "A  carrier_mat 2 n" using A by auto
        have "Smith_mxn A = Smith_2xn A" using Smith_mxn.simps True 1 2 by auto
        then show ?thesis using is_SNF_Smith_2xn[OF A'] A by auto
      next
        case False note 3 = False
        show ?thesis 
        proof (cases "dim_col A = 1")
          case True
          hence A': "A  carrier_mat m 1" using A by auto
          have "Smith_mxn A = (let (P,S) = Smith_nx1 A in (P,S,1m 1))" 
            using Smith_mxn.simps True 1 2 3 by auto
          then show ?thesis using Smith_nx1_works[OF A'] A by (auto simp add: case_prod_beta)          
        next
          case False
          hence "dim_col A = 2" using 1 2 3 mn A by auto
          hence A': "A  carrier_mat m 2" using A by auto
          hence "Smith_mxn A = Smith_nx2 A" 
            using Smith_mxn.simps 1 2 3 False by auto
          then show ?thesis using is_SNF_Smith_nx2[OF A'] A by force
        qed
      qed  
    qed
  qed
qed


lemma is_SNF_Smith_mxn_ge_2: 
  assumes A: "A  carrier_mat m n" and m: "m>2" and n: "n>2"
  shows "is_SNF A (Smith_mxn A)"
  using A m n
proof (induct A arbitrary: m n rule: Smith_mxn.induct)
  case (1 A)
  note A = "1.prems"(1)
  note m = "1.prems"(2)
  note n = "1.prems"(3)  
  have A_dim_not0:  "¬ (dim_row A = 0  dim_col A = 0)" and A_dim_row_not1: "dim_row A  1"
    and A_dim_row_not2: "dim_row A  2" and A_dim_col_not1: "dim_col A  1"
    and A_dim_col_not2: "dim_col A  2"
    using A m n by auto
  note A_dim_intro = A_dim_not0 A_dim_row_not1 A_dim_row_not2 A_dim_col_not1 A_dim_col_not2
  define A1 where "A1 = mat_of_row (Matrix.row A 0)"
  define A2 where "A2 = mat_of_rows (dim_col A) [Matrix.row A i. i  [1..<dim_row A]]"
  obtain P1 D1 Q1 where P1D1Q1: "(P1,D1,Q1) = Smith_mxn A2" by (metis prod_cases3)
  define C where "C = (A1*Q1) @r (P1*A2*Q1)"
  define D where "D = mat_of_rows (dim_col A) [Matrix.row C 0, Matrix.row C 1]"
  define E where "E = mat_of_rows (dim_col A) [Matrix.row C i. i  [2..<dim_row A]]"
  obtain P2 F Q2 where P2FQ2: "(P2,F,Q2) = Smith_2xn D" by (metis prod_cases3)
  define H where "H = (P2*D*Q2) @r (E*Q2)"
  obtain P_H2 H2 where P_H2H2: "(P_H2, H2) = reduce_column div_op H" by (metis surj_pair)
  obtain H2_UL H2_UR H2_DL H2_DR where split_H2: "(H2_UL, H2_UR, H2_DL, H2_DR) = split_block H2 1 1"
    by (metis split_block_def)
  obtain P3 S' Q3 where P3S'Q3: "(P3,S',Q3) = Smith_mxn H2_DR" by (metis prod_cases3)
  define S where "S = four_block_mat (Matrix.mat 1 1 (λ(a, b). H $$ (0, 0))) (0m 1 (dim_col A - 1))
    (0m (dim_row A - 1) 1) S'"
  define P1' where "P1' = four_block_mat (1m 1) (0m 1 (dim_row A - 1)) (0m (dim_row A - 1) 1) P1"
  define P2' where "P2' = four_block_mat P2 (0m 2 (dim_row A - 2)) (0m (dim_row A - 2) 2) (1m (dim_row A - 2))"
  define P3' where "P3' = four_block_mat (1m 1) (0m 1 (dim_row A - 1)) (0m (dim_row A - 1) 1) P3"
  define Q3' where "Q3' = four_block_mat (1m 1) (0m 1 (dim_col A - 1)) (0m (dim_col A - 1) 1) Q3"
  have Smith_final: "Smith_mxn A = (P3' * P_H2 * P2' * P1', S, Q1 * Q2 * Q3')"
  proof -
    have P1_def: "P1 = fst (Smith_mxn A2)" and D1_def: "D1 = fst (snd (Smith_mxn A2))" 
      and Q1_def: "Q1 = snd (snd (Smith_mxn A2))" using P1D1Q1 by (metis fstI sndI)+
    have P2_def: "P2 = fst (Smith_2xn D)" and F_def: "F = fst (snd (Smith_2xn D))" 
      and Q2_def: "Q2 = snd (snd (Smith_2xn D))" using P2FQ2 by (metis fstI sndI)+
    have P_H2_def: "P_H2 = fst (reduce_column div_op H)"
      and H2_def: "H2 = snd (reduce_column div_op H)" 
      using P_H2H2 by (metis fstI sndI)+
    have H2_UL_def: "H2_UL = fst (split_block H2 1 1)" 
      and H2_UR_def: "H2_UR = fst (snd (split_block H2 1 1))" 
      and H2_DL_def: "H2_DL = fst (snd (snd (split_block H2 1 1)))" 
      and H2_DR_def: "H2_DR = snd (snd (snd (split_block H2 1 1)))"
      using split_H2 by (metis fstI sndI)+
    have P3_def: "P3 = fst (Smith_mxn H2_DR)" and S'_def: "S' = fst (snd (Smith_mxn H2_DR))" 
      and Q3_def: "Q3 = (snd (snd (Smith_mxn H2_DR)))" using P3S'Q3 by (metis fstI sndI)+
    note aux = Smith_mxn.simps[of A] Let_def split_beta
      A1_def[symmetric] A2_def[symmetric] P1_def[symmetric] D1_def[symmetric] Q1_def[symmetric]
      C_def[symmetric] D_def[symmetric] E_def[symmetric] P2_def[symmetric] Q2_def[symmetric]
      F_def[symmetric] H_def[symmetric] P_H2_def[symmetric] H2_def[symmetric] H2_UL_def[symmetric]
      H2_DL_def[symmetric] H2_UR_def[symmetric] H2_DR_def[symmetric] P3_def[symmetric] S'_def[symmetric]
      Q3_def[symmetric] P1'_def[symmetric] P2'_def[symmetric] P3'_def[symmetric] Q1_def[symmetric]
      Q2_def[symmetric] Q3'_def[symmetric] S_def[symmetric]
    show ?thesis by (rule prod3_intro, unfold aux, insert "1.prems", auto)
  qed
  show ?case
  proof (unfold Smith_final, rule is_SNF_intro)
    have A1[simp]: "A1  carrier_mat 1 n" unfolding A1_def using A by auto
    have A2[simp]: "A2  carrier_mat (m-1) n" unfolding A2_def using A by auto
    have is_SNF_A2: "is_SNF A2 (Smith_mxn A2)"
    proof (cases "n  2  m - 1  2")
      case True
      then show ?thesis using is_SNF_Smith_mxn_less_2[OF A2] by simp
    next
      case False
      hence n1: "2<n" and m1: "2<m-1" by auto
      show ?thesis by (rule "1.hyps"(1)[OF A_dim_intro A1_def A2_def A2 m1 n1])        
    qed
    have P1[simp]: "P1  carrier_mat (m-1) (m-1)" 
      and inv_P1: "invertible_mat P1" 
      and Q1: "Q1  carrier_mat n n" and inv_Q1: "invertible_mat Q1"
      and SNF_P1A2Q1: "Smith_normal_form_mat (P1*A2*Q1)"
      using is_SNF_A2 P1D1Q1 A2 A n m unfolding is_SNF_def by auto
    have C[simp]: "C  carrier_mat m n" unfolding C_def  using P1 Q1 A1 A2 m
      by (smt "1"(3) A_dim_not0 Suc_pred card_num_simps(30) carrier_append_rows carrier_matD 
          carrier_mat_triv index_mult_mat(2,3) neq0_conv plus_1_eq_Suc)
    have D[simp]: "D  carrier_mat 2 n" unfolding D_def using A m by auto  
    have is_SNF_D: "is_SNF D (Smith_2xn D)" by (rule is_SNF_Smith_2xn[OF D])
    hence P2[simp]: "P2  carrier_mat 2 2" and inv_P2: "invertible_mat P2"
      and Q2[simp]: "Q2  carrier_mat n n" and inv_Q2: "invertible_mat Q2"
      and F[simp]: "F  carrier_mat 2 n" and F_P2DQ2: "F = P2*D*Q2"
      and SNF_F: "Smith_normal_form_mat F"
      using P2FQ2 D_def A unfolding is_SNF_def by auto
    have E[simp]: "E  carrier_mat (m-2) n" unfolding E_def using A by auto
    have H_aux: "H  carrier_mat (2 + (m-2)) n" unfolding H_def 
      by (rule carrier_append_rows, insert P2 D Q2 E F_P2DQ2 F A m n mult_carrier_mat, force)    
    hence H[simp]: "H  carrier_mat m n" using m by auto
    have H2[simp]: "H2  carrier_mat m n" using m H P_H2H2 A reduce_column by blast
    have H2_DR[simp]: "H2_DR  carrier_mat (m - 1) (n - 1)"
      by (rule split_block(4)[OF split_H2[symmetric]], insert H2 m n A H, auto, insert H2, blast+)    
    have P1'[simp]: "P1'  carrier_mat m m" unfolding P1'_def using P1 m by auto
    have P2'[simp]: "P2'  carrier_mat m m" unfolding P2'_def using P2 m A m 
      by (metis (no_types, lifting) H H_aux carrier_matD carrier_mat_triv 
          index_mat_four_block(2,3) index_one_mat(2,3))
    have is_SNF_H2_DR: "is_SNF H2_DR (Smith_mxn H2_DR)"
    proof (cases "2 < m - 1  2 < n - 1")
      case True
      hence m1: "2<m-1" and n1: "2<n-1" by simp+
      show ?thesis
        by (rule "1.hyps"(2)[OF A_dim_intro A1_def A2_def P1D1Q1 _ _ C_def D_def E_def P2FQ2 _ _ H_def
              P_H2H2 _ split_H2 _ _ _ H2_DR m1 n1], auto)
    next
      case False
      hence "m-12  n-12" by auto
      then show ?thesis using H2_DR is_SNF_Smith_mxn_less_2 by blast
    qed
    hence P3[simp]: "P3  carrier_mat (m-1) (m-1)" and inv_P3: "invertible_mat P3"
      and Q3[simp]: "Q3  carrier_mat (n-1) (n-1)" and inv_Q3: "invertible_mat Q3"
      and S'[simp]: "S'  carrier_mat (m-1) (n-1)" and S'_P3H2_DRQ3: "S' = P3 * H2_DR * Q3"
      and SNF_S': "Smith_normal_form_mat S'"
      using A m n H2_DR P3S'Q3 unfolding is_SNF_def by auto
    have P3'[simp]: "P3'  carrier_mat m m" unfolding P3'_def using P3 m by auto
    have P_H2[simp]: "P_H2  carrier_mat m m" using reduce_column[OF H P_H2H2] m by simp
    have S[simp]: "S  carrier_mat m n" unfolding S_def using H A S'
      by (smt A_dim_intro(1) One_nat_def Suc_pred carrier_matD carrier_matI dim_col_mat(1)
          dim_row_mat(1) index_mat_four_block(2,3) nat_neq_iff not_less_zero plus_1_eq_Suc)
    have Q3'[simp]: "Q3'  carrier_mat n n" unfolding Q3'_def using Q3 n by auto
        (*The following two goals could have been resolved with Smith_mxn_pinduct_carrier, but we need the 
  dimensions of each matrix anyway*)
    show P_final_carrier: "P3' * P_H2 * P2' * P1'  carrier_mat (dim_row A) (dim_row A)" 
      using P3' P_H2 P2' P1' A by (metis carrier_matD carrier_matI index_mult_mat(2,3))
    show Q_final_carrier: "Q1 * Q2 * Q3'  carrier_mat (dim_col A) (dim_col A)"
      using Q1 Q2 Q3' A by (metis carrier_matD carrier_matI index_mult_mat(2,3))
    have inv_P1': "invertible_mat P1'" unfolding P1'_def
      by (rule invertible_mat_four_block_mat_lower_right[OF _ inv_P1], insert A P1, auto)
    have inv_P2': "invertible_mat P2'" unfolding P2'_def
      by (rule invertible_mat_four_block_mat_lower_right_id[OF _ _ _ _ _ inv_P2], insert A m, auto)
    have inv_P3': "invertible_mat P3'" unfolding P3'_def
      by (rule invertible_mat_four_block_mat_lower_right[OF _ inv_P3], insert A P3, auto)
    have inv_P_H2: "invertible_mat P_H2" using reduce_column[OF H P_H2H2] m by simp
    show "invertible_mat (P3' * P_H2 * P2' * P1')" using inv_P1' inv_P2' inv_P3' inv_P_H2
      by (meson P1' P2' P3' P_H2 invertible_mult_JNF mult_carrier_mat)
    have inv_Q3': "invertible_mat Q3'" unfolding Q3'_def
      by (rule invertible_mat_four_block_mat_lower_right[OF _ inv_Q3], insert A Q3, auto)    
    show "invertible_mat (Q1 * Q2 * Q3')" using inv_Q1 inv_Q2 inv_Q3'    
      by (meson Q1 Q2 Q3' invertible_mult_JNF mult_carrier_mat)  
    have A_A1_A2: "A = A1 @r A2" unfolding append_cols_def 
    proof (rule eq_matI)
      have A1_A2': "A1 @r A2  carrier_mat (1+(m-1)) n" by (rule carrier_append_rows[OF A1 A2])
      hence A1_A2: "A1 @r A2  carrier_mat m n" using m by simp
      thus "dim_row A = dim_row (A1 @r A2)" and "dim_col A = dim_col (A1 @r A2)" using A by auto
      fix i j assume i: "i < dim_row (A1 @r A2)" and j: "j < dim_col (A1 @r A2)"
      show "A $$ (i, j) = (A1 @r A2) $$ (i, j)"
      proof (cases "i=0")
        case True
        have "(A1 @r A2) $$ (i, j) = (A1 @r A2) $$ (0, j)" using True by simp
        also have "... = four_block_mat A1 (0m (dim_row A1) 0) A2 (0m (dim_row A2) 0) $$ (0,j)"
          unfolding append_rows_def ..
        also have "... = A1 $$ (0,j)" using A1 A1_A2 j by auto
        also have "... = A $$ (0,j)" unfolding A1_def using A1_A2 A i j by auto
        finally show ?thesis using True by simp
      next
        case False
        let ?xs = "(map (Matrix.row A) [1..<dim_row A])"
        have "(A1 @r A2) $$ (i, j) = four_block_mat A1 (0m (dim_row A1) 0) A2 (0m (dim_row A2) 0) $$ (i,j)"
          unfolding append_rows_def ..
        also have "... = A2 $$ (i-1,j)" using A1 A1_A2' A2 False i j by auto
        also have "... = mat_of_rows (dim_col A) ?xs $$ (i - 1, j)" by (simp add: A2_def)
        also have "... = ?xs ! (i-1) $v j" by (rule mat_of_rows_index, insert i False A j m A1_A2, auto)
        also have "... = A $$ (i,j)" using False A A1_A2 i j by auto
        finally show ?thesis ..
      qed    
    qed
    have C_eq: "C = P1' * A * Q1"
    proof -
      have aux: "(A1 @r A2) * Q1 = ((A1 * Q1) @r (A2*Q1))"
        by (rule append_rows_mult_right, insert A1 A2 Q1, auto)
      have "P1' * A * Q1 = P1' * (A1 @r A2) * Q1" using A_A1_A2 by simp
      also have "... =  P1' * ((A1 @r A2) * Q1)" using A A_A1_A2 P1' Q1 assoc_mult_mat by blast
      also have "... = P1' * ((A1 * Q1) @r (A2*Q1))" by (simp add: aux)
      also have "... = (A1 * Q1) @r (P1 * (A2 * Q1))" 
        by (rule append_rows_mult_left_id, insert A1 Q1 A2 P1 P1'_def A, auto)
      also have "... = (A1 * Q1) @r (P1 * A2 * Q1)" using A2 P1 Q1 by auto
      finally show ?thesis unfolding C_def ..
    qed
    have C_D_E: "C = D @r E"
    proof -
      let ?xs = "[Matrix.row C 0, Matrix.row C 1]"
      let ?ys = "(map (Matrix.row C) [0..<2])" 
      have xs_ys: "?xs = ?ys" by (simp add: upt_conv_Cons)
      have D_rw: "D = mat_of_rows (dim_col C) (map (Matrix.row C) [0..<2])" 
        unfolding D_def xs_ys using A C by (metis carrier_matD(2))
      have d1: "dim_col A = dim_col C" using A C by blast
      have d2: "dim_row A = dim_row C" using A C by blast
      show ?thesis unfolding D_rw E_def d1 d2 by (rule append_rows_split, insert m C A d2, auto)
    qed
    have H_eq: "H = P2' * P1' * A * Q1 * Q2"
    proof -
      have aux: "((P2 * D) @r E) = P2' * (D @r E)" 
        by (rule append_rows_mult_left_id2[symmetric, OF D E _ P2], insert P2'_def A, auto)
      have "H = P2 * D * Q2 @r E * Q2" by (simp add: H_def)
      also have "... = (P2 * D @r E) * Q2" 
        by (rule append_rows_mult_right[symmetric, OF mult_carrier_mat[OF P2 D] E Q2])
      also have "... = P2' * (D @r E) * Q2" by (simp add: aux)
      also have "... =  P2' * C * Q2" unfolding C_D_E by simp
      also have "... = P2' * (P1' * A * Q1) * Q2" unfolding C_eq by simp
      also have "... = P2' * P1' * A * Q1 * Q2"
        by (smt A P1' P2' Q1 P2' * C * Q2 = P2' * (P1' * A * Q1) * Q2 assoc_mult_mat mult_carrier_mat)
      finally show ?thesis .    
    qed
    have P_H2_H_H2: "P_H2 * H = H2" using reduce_column[OF H P_H2H2] m by auto
    hence H2_eq: "H2 = P_H2 * P2' * P1' * A * Q1 * Q2" unfolding H_eq
      by (smt P1' P1'_def P2' P2'_def P_H2 P_final_carrier Q1 Q2 Q_final_carrier assoc_mult_mat 
          carrier_matD carrier_mat_triv index_mult_mat(2,3))        
    have H2_as_four_block_mat: "H2 = four_block_mat H2_UL H2_UR H2_DL H2_DR" 
      using split_H2 by (metis (no_types, lifting) H2 P1' P1'_def Q3' Q3'_def carrier_matD 
          index_mat_four_block(2) index_one_mat(2) split_block(5))
    have H2_UL: "H2_UL  carrier_mat 1 1" 
      by (rule split_block(1)[OF split_H2[symmetric], of "m-1" "n-1"], insert H2 A m n, auto, insert H2, blast+)
    have H2_UR: "H2_UR  carrier_mat 1 (n-1)"
      by (rule split_block(2)[OF split_H2[symmetric], of "m-1"], insert H2 A m n, auto, insert H2, blast+)
    have H2_DL: "H2_DL  carrier_mat (m-1) 1"
      by (rule split_block(3)[OF split_H2[symmetric], of _ "n-1"], insert H2 A m n, auto, insert H2, blast+)
    have H2_DR: "H2_DR  carrier_mat (m-1) (n-1)"
      by (rule split_block(4)[OF split_H2[symmetric], of _ "n-1"], insert H2 A m n, auto, insert H2, blast+)
    have H_ij_F_ij: "H$$(i,j) = F $$(i,j)" if i: "i<2" and j: "j<n" for i j
    proof -
      have "H$$(i,j) = (if i < dim_row (P2*D*Q2) then (P2*D*Q2) $$ (i, j) else (E*Q2) $$ (i - 2, j))"      
      proof (unfold H_def, rule append_rows_nth)
        show "P2 * D * Q2  carrier_mat 2 n" using F F_P2DQ2 by blast
        show "E * Q2  carrier_mat (m-2) n" using E Q2 using mult_carrier_mat by blast
      qed (insert m j i, auto)
      also have "... = F $$ (i, j)" using F F_P2DQ2 i by auto
      finally show ?thesis .
    qed
    have isDiagonal_F: "isDiagonal_mat F" 
      using is_SNF_D P2FQ2 unfolding is_SNF_def Smith_normal_form_mat_def by auto
    have H_0j_0: "H $$ (0,j) = 0" if j: "j{1..<n}" for j
    proof -   
      have "H $$ (0,j) = F $$ (0, j)" using H_ij_F_ij j by auto
      also have "... = 0" using isDiagonal_F unfolding isDiagonal_mat_def using F j by auto
      finally show ?thesis .    
    qed
    have H2_0j: "H2 $$ (0,j) = H $$ (0,j)" if j: "j<n" for j
      by (rule reduce_column_preserves2[OF H P_H2H2 _ _ _ j], insert m, auto)
    have H2_UR_0: "H2_UR = (0m 1 (n-1))"
    proof (rule eq_matI)
      show "dim_row H2_UR = dim_row (0m 1 (n - 1))" and "dim_col H2_UR = dim_col (0m 1 (n - 1))"
        using H2_UR by auto
      fix i j assume i: "i < dim_row (0m 1 (n - 1))" and j: "j < dim_col (0m 1 (n - 1))"
      have i0: "i=0" using i by auto
      have 1: "0 < dim_row H2_UL + dim_row H2_DR" using i H2_UL H2_DR by auto
      have 2: "j+1 < dim_col H2_UL + dim_col H2_DR" using j H2_UL H2_DR by auto
      have "H2_UR $$ (i, j) = H2 $$ (0,j+1)"
        unfolding i0 H2_as_four_block_mat using index_mat_four_block(1)[OF 1 2] H2_UL by auto
      also have "... = H $$ (0,j+1)" by (rule H2_0j, insert j, auto)
      also have "... = 0" using H_0j_0 j by auto
      finally show "H2_UR $$ (i, j) = 0m 1 (n - 1) $$ (i, j)" using i j by auto
    qed
    have H2_UL00_H00: "H2_UL $$ (0,0) = H $$ (0,0)"
      using H2_UL H2_as_four_block_mat H2_0j n by fastforce
    have F00_dvd_Dij: "F$$(0,0) dvd D$$(i,j)" if i: "i<2" and j: "j<n" for i j
      by (rule S00_dvd_all_A[OF D P2 Q2 inv_P2 inv_Q2 F_P2DQ2 SNF_F i j])
        (*
    Scheme of the proof:
    - D $$ (1,0) dvd all elements of E
    - F$$(0,0) divides all elements of D, in particular divides D$$(1,0)
    - Hence, F$$(0,0) divides all elements of E.
    - Hence, F$$(0,0) divides all elements of E * Q2
  *)
    have D10_dvd_Eij: "D$$(1,0) dvd E$$(i,j)" if i: "i<m-2" and j: "j<n" for i j
    proof -
      have "D$$(1,0) = C$$(1,0)"
        by (smt C C_D_E F F_P2DQ2 H H_def One_nat_def Suc_lessD add_diff_cancel_right' append_rows_def
            arith_special(3) carrier_matD index_mat_four_block index_mult_mat(2) lessI m n plus_1_eq_Suc)
      also have "... = (P1*A2*Q1) $$ (0,0)"
        by (smt "1"(3) A1 A2 A_A1_A2 A_dim_not0 P1 Q1 Suc_eq_plus1 Suc_lessD add_diff_cancel_right' 
            append_rows_def arith_special(3) card_num_simps(30) carrier_matD index_mat_four_block 
            index_mult_mat(2,3) less_not_refl2 local.C_def m neq0_conv)
      also have " ... dvd (P1*A2*Q1) $$ (i+1,j)"
        by (rule SNF_first_divides_all[OF SNF_P1A2Q1 _ _ j], insert P1 A2 Q1 i A, auto)
      also have "... = C $$ (i+2,j)" unfolding C_def using append_rows_nth
        by (smt A A1 A2 A_A1_A2 P1 Q1 Suc_lessD add_Suc_right add_diff_cancel_left' append_rows_def
            arith_special(3) carrier_matD index_mat_four_block index_mult_mat(2,3) j less_diff_conv 
            not_add_less2 plus_1_eq_Suc that(1))
      also have "... = E$$(i,j)"
        by (smt C C_D_E D add_diff_cancel_right' append_rows_def carrier_matD index_mat_four_block j i
            less_diff_conv not_add_less2)
      finally show ?thesis .   
    qed
    have F00_H00: "F $$ (0,0) = H $$ (0,0)" using H_ij_F_ij n by auto
    have F00_dvd_Eij: "F$$(0,0) dvd E$$(i,j)" if i: "i<m-2" and j: "j<n" for i j
      by (metis (no_types, lifting) A A_dim_not0 D10_dvd_Eij F00_dvd_Dij arith_special(3) carrier_matD(2) 
          dvd_trans j lessI neq0_conv plus_1_eq_Suc i)
    have F00_dvd_EQ2ij: "F$$(0,0) dvd (E*Q2) $$ (i,j)" if i: "i<m-2" and j: "j<n" for i j
      using dvd_elements_mult_matrix_right[OF E Q2]  F00_dvd_Eij i j by auto
    have H00_dvd_all: "H $$ (0, 0) dvd H $$ (i, j)" if i: "i<m" and j: "j<n" for i j
    proof (cases "i<2")
      case True
      then show ?thesis by (metis F F00_H00 H_ij_F_ij SNF_F SNF_first_divides_all j)
    next
      case False
      have "F $$ (0,0) dvd (E*Q2) $$ (i-2,j)" by (rule F00_dvd_EQ2ij, insert False i j, auto)
      moreover have "H $$ (i, j) = (E*Q2) $$ (i-2,j)"
        by (smt C C_D_E D F F_P2DQ2 False H_def append_rows_def carrier_matD i 
            index_mat_four_block index_mult_mat(2) j)
      ultimately show ?thesis using F00_H00 by simp
    qed    
    have H_00_dvd_H_i0: "H $$ (0, 0) dvd H $$ (i, 0)" if i: "i<m" for i
      using H00_dvd_all[OF i] n by auto
    have H2_DL_0: "H2_DL = (0m (m - 1) 1)"
    proof (rule eq_matI)
      show "dim_row (H2_DL) = dim_row (0m (m - 1) 1)"
        and "dim_col (H2_DL) = dim_col (0m (m - 1) 1)" using P3 H2_DL A by auto
      fix i j assume i: "i < dim_row (0m (m - 1) 1)" and j: "j < dim_col (0m (m - 1) 1)"
      have j0: "j=0" using j by auto
      have "(H2_DL) $$ (i, j) = H2 $$ (i+1,0)"
        using H2_UR H2_UR_0 n j0 H2 H2_UL H2_as_four_block_mat i by auto
      also have "... = 0"
      proof (cases "i=0")
        case True
        have "H2 $$ (1,0) = H $$ (1,0)" by (rule reduce_column_preserves2[OF H P_H2H2], insert m n, auto)
        also have "... = F $$ (1,0)" by (rule H_ij_F_ij, insert n, auto)
        also have "... = 0" using isDiagonal_F F n unfolding isDiagonal_mat_def by auto
        finally show ?thesis by (simp add: True)
      next
        case False
        show ?thesis
        proof (rule reduce_column_works(1)[OF H P_H2H2])      
          show "H $$ (0, 0) dvd H $$ (i + 1, 0)" using H_00_dvd_H_i0 False i by simp
          show "j{1..<n}. H $$ (0, j) = 0" using H_0j_0 by auto
          show "i + 1  {2..<m}" using i False by auto
        qed (insert m n id, auto)
      qed
      finally show "(H2_DL) $$ (i, j) = 0m (m - 1) 1 $$ (i, j)" using i j j0 by auto
    qed
    have "P3'*H2 = four_block_mat H2_UL H2_UR (P3 * H2_DL) (P3 * H2_DR)"
    proof -
      have "P3'*H2 = four_block_mat 
    (1m 1 * H2_UL + 0m 1 (dim_row A - 1) * H2_DL) (1m 1 * H2_UR + 0m 1 (dim_row A - 1) * H2_DR) 
    (0m (dim_row A - 1) 1 * H2_UL + P3 * H2_DL) (0m (dim_row A - 1) 1 * H2_UR + P3 * H2_DR)"
        unfolding P3'_def H2_as_four_block_mat 
        by (rule mult_four_block_mat[OF _ _ _ P3 H2_UL H2_UR H2_DL H2_DR], insert A, auto)
      also have "... = four_block_mat H2_UL H2_UR (P3 * H2_DL) (P3 * H2_DR)"
        by (rule cong_four_block_mat, insert H2_UL A m H2_DL H2_DR H2_UR P3, auto) 
      finally show ?thesis .
    qed
    hence P3'_H2_as_four_block_mat: "P3'*H2 = four_block_mat H2_UL (0m 1 (n-1)) (0m (m - 1) 1) (P3 * H2_DR)"
      unfolding H2_UR_0 H2_DL_0 using P3 by auto
    also have "... * Q3' = S" (is "?lhs = ?rhs")
    proof -
      have "?lhs = four_block_mat H2_UL (0m 1 (n-1)) (0m (m - 1) 1) (P3 * H2_DR) 
    * four_block_mat (1m 1) (0m 1 (n - 1)) (0m (n - 1) 1) Q3" unfolding Q3'_def using A by auto
      also have "... = 
    four_block_mat (H2_UL * 1m 1 + (0m 1 (n-1)) * 0m (n - 1) 1) (H2_UL * 0m 1 (n - 1) + (0m 1 (n-1)) * Q3)
     (0m (m - 1) 1 * 1m 1 + P3 * H2_DR * 0m (n - 1) 1) (0m (m - 1) 1 * 0m 1 (n - 1) + P3 * H2_DR * Q3)"
        by (rule mult_four_block_mat[OF H2_UL], insert P3 H2_DR Q3, auto)
      also have "... = four_block_mat H2_UL (0m 1 (n - 1)) (0m (m - 1) 1) (P3 * H2_DR * Q3)"
        by (rule cong_four_block_mat, insert H2_UL A m H2_DL H2_DR H2_UR P3 Q3, auto)
      also have "... = four_block_mat (Matrix.mat 1 1 (λ(a, b). H $$ (0, 0))) 
      (0m 1 (dim_col A - 1)) (0m (dim_row A - 1) 1) S'"
        by (rule cong_four_block_mat, insert A S'_P3H2_DRQ3 H2_UL00_H00 H2_UL, auto)    
      finally show ?thesis unfolding S_def by simp
    qed
    finally have P3'_H2_Q3'_S: "P3'*H2*Q3' = S" .
    have S_as_four_block_mat: "S = four_block_mat H2_UL (0m 1 (n - 1)) (0m (m - 1) 1) S'"
      unfolding S_def by (rule cong_four_block_mat, insert A S'_P3H2_DRQ3 H2_UL00_H00 H2_UL, auto)    
    show "S = P3' * P_H2 * P2' * P1' * A * (Q1 * Q2 * Q3')" using P3'_H2_Q3'_S unfolding H2_eq
      by (smt P1 P1'_def P2' P2'_def P3 P3'_def P_H2 Q1 Q2 Q3' Q3'_def S Q_final_carrier P_final_carrier
          assoc_mult_mat carrier_matD carrier_mat_triv index_mat_four_block(2,3) index_mult_mat(2,3))
    have H00_dvd_all_H2: "H $$ (0, 0) dvd H2 $$ (i, j)" if i: "i<m" and j: "j<n" for i j
      using  dvd_elements_mult_matrix_left[OF H P_H2] H00_dvd_all i j P_H2_H_H2 by blast
    hence H00_dvd_all_S: "H $$ (0, 0) dvd S $$ (i, j)" if i: "i<m" and j: "j<n" for i j
      using dvd_elements_mult_matrix_left_right[OF H2 P3' Q3'] P3'_H2_Q3'_S i j by auto
    show "Smith_normal_form_mat S"
    proof (rule Smith_normal_form_mat_intro)    
      show "isDiagonal_mat S"
      proof (unfold isDiagonal_mat_def, rule+)
        fix i j assume  "i  j  i < dim_row S  j < dim_col S"
        hence ij: "i  j" and i: "i < dim_row S" and j: "j < dim_col S" by auto
        have i2: "i < dim_row H2_UL + dim_row S'" and j2: "j < dim_col H2_UL + dim_col S'"
          using S_as_four_block_mat i j by auto
        have "S $$ (i,j) = (if i < dim_row H2_UL then if j < dim_col H2_UL then H2_UL $$ (i, j) 
      else (0m 1 (n - 1)) $$ (i, j - dim_col H2_UL) else if j < dim_col H2_UL 
      then (0m (m - 1) 1) $$ (i - dim_row H2_UL, j) else S' $$ (i - dim_row H2_UL, j - dim_col H2_UL))"
          by (unfold S_as_four_block_mat, rule index_mat_four_block(1)[OF i2 j2])
        also have "... = 0" (is "?lhs = 0")
        proof (cases "i = 0  j = 0")
          case True
          then show ?thesis unfolding S_def using ij i j S H2_UL by fastforce      
        next
          case False
          have diag_S': "isDiagonal_mat S'" using SNF_S' unfolding Smith_normal_form_mat_def by simp
          have i_not_0: "i0" and j_not_0: "j0" using False by auto
          hence "?lhs = S' $$ (i - dim_row H2_UL, j - dim_col H2_UL)" using i j ij H2_UL by auto
          also have "... = 0" using diag_S' S' H2_UL i_not_0 j_not_0 ij unfolding isDiagonal_mat_def
            by (smt S_as_four_block_mat add_diff_inverse_nat add_less_cancel_left carrier_matD i 
                index_mat_four_block(2,3) j less_one)
          finally show ?thesis .
        qed
        finally show "S $$ (i, j) = 0" .
      qed
      show "a. a + 1 < min (dim_row S) (dim_col S)  S $$ (a, a) dvd S $$ (a + 1, a + 1)"
      proof safe
        fix i assume i: "i + 1 < min (dim_row S) (dim_col S)"
        show "S $$ (i, i) dvd S $$ (i + 1, i + 1)"
        proof (cases "i=0")
          case True
          have "S $$ (0, 0) = H $$ (0,0)" using H2_UL H2_UL00_H00 S_as_four_block_mat by auto
          also have "... dvd S $$ (1,1)" using H00_dvd_all_S i m n by auto
          finally show ?thesis using True by simp
        next
          case False
          have "S $$ (i, i)= S' $$ (i-1, i-1)" using False S_def i by auto
          also have "... dvd S' $$ (i, i)" using SNF_S' i S' S unfolding Smith_normal_form_mat_def
            by (smt False H2_UL S_as_four_block_mat add.commute add_diff_inverse_nat carrier_matD 
                index_mat_four_block(2,3) less_one min_less_iff_conj nat_add_left_cancel_less)
          also have "... = S $$ (i+1,i+1)" using False S_def i by auto
          finally show ?thesis .
        qed
      qed
    qed
  qed
qed

subsection ‹Soundness theorem›

theorem is_SNF_Smith_mxn: 
  assumes A: "A  carrier_mat m n"
  shows "is_SNF A (Smith_mxn A)"
  using is_SNF_Smith_mxn_ge_2[OF A] is_SNF_Smith_mxn_less_2[OF A] by linarith

declare Smith_mxn.simps[code]

end

declare Smith_Impl.Smith_mxn.simps[code_unfold]

definition T_spec :: "('a::{comm_ring_1}  'a  ('a × 'a × 'a))  bool" 
  where "T_spec T = (a b::'a. let (a1,b1,d) = T a b in 
                    a = a1*d  b = b1*d  ideal_generated {a1,b1} = ideal_generated {1})"

definition D'_spec :: "('a::{comm_ring_1}  'a  'a  ('a × 'a))  bool" 
  where "D'_spec D' = (a b c::'a. let (p,q) = D' a b c in 
      ideal_generated{a,b,c} = ideal_generated{1} 
       ideal_generated {p*a,p*b+q*c} = ideal_generated {1})"

end

Theory SNF_Algorithm_HOL_Analysis

(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section ‹The Smith normal form algorithm in HOL Analysis›

theory SNF_Algorithm_HOL_Analysis
  imports
    SNF_Algorithm
    Admits_SNF_From_Diagonal_Iff_Bezout_Ring
begin

subsection ‹Transferring the result from JNF to HOL Anaylsis›

(*Now, we transfer the algorithm to HMA and get the final lemma.*)

definition Smith_mxn_HMA :: "(('a::comm_ring_1^2)  (('a^2) × ('a^2^2)))
    (('a^2^2)  (('a^2^2) × ('a^2^2) × ('a^2^2)))  ('a'a'a)  ('a^'n::mod_type^'m::mod_type) 
   (('a^'m::mod_type^'m::mod_type)× ('a^'n::mod_type^'m::mod_type) × ('a^'n::mod_type^'n::mod_type))"
  where
"Smith_mxn_HMA Smith_1x2 Smith_2x2 div_op A =
  (let Smith_1x2_JNF = (λA'. let (S',Q') = Smith_1x2 (Mod_Type_Connect.to_hmav (Matrix.row A' 0))
                        in (mat_of_row (Mod_Type_Connect.from_hmav S'), Mod_Type_Connect.from_hmam Q'));
       Smith_2x2_JNF = (λA'. let (P', S',Q') = Smith_2x2 (Mod_Type_Connect.to_hmam A') 
                        in (Mod_Type_Connect.from_hmam P', Mod_Type_Connect.from_hmam S', Mod_Type_Connect.from_hmam Q'));
       (P,S,Q) = Smith_Impl.Smith_mxn Smith_1x2_JNF Smith_2x2_JNF div_op (Mod_Type_Connect.from_hmam A)
  in (Mod_Type_Connect.to_hmam P, Mod_Type_Connect.to_hmam S, Mod_Type_Connect.to_hmam Q)
  )"


definition "is_SNF_HMA A R = (case R of (P,S,Q)  
   invertible P  invertible Q 
   Smith_normal_form S  S = P ** A ** Q)"

subsection ‹Soundness in HOL Anaylsis›

lemma is_SNF_Smith_mxn_HMA:
  fixes A::"'a::comm_ring_1 ^ 'n::mod_type ^ 'm::mod_type"
  assumes PSQ: "(P,S,Q) = Smith_mxn_HMA Smith_1x2 Smith_2x2 div_op A"
  and SNF_1x2_works: "A. let (S',Q) = Smith_1x2 A in S' $h 1 = 0  invertible Q  S' = A v* Q"
    and SNF_2x2_works: "A. is_SNF_HMA A (Smith_2x2 A)"
    and d: "is_div_op div_op"
  shows "is_SNF_HMA A (P,S,Q)"
proof -
  let ?A = "Mod_Type_Connect.from_hmam A"
  define Smith_1x2_JNF where "Smith_1x2_JNF = (λA'. let (S',Q') 
    = Smith_1x2 (Mod_Type_Connect.to_hmav (Matrix.row A' 0))
    in (mat_of_row (Mod_Type_Connect.from_hmav S'), Mod_Type_Connect.from_hmam Q'))"
  define Smith_2x2_JNF where "Smith_2x2_JNF = (λA'. let (P', S',Q') = Smith_2x2 (Mod_Type_Connect.to_hmam A') 
    in (Mod_Type_Connect.from_hmam P', Mod_Type_Connect.from_hmam S', Mod_Type_Connect.from_hmam Q'))"
  obtain P' S' Q' where P'S'Q': "(P',S',Q') = Smith_Impl.Smith_mxn Smith_1x2_JNF Smith_2x2_JNF div_op ?A"    
    by (metis prod_cases3)
  have PSQ_P'S'Q': "(P,S,Q) = 
      (Mod_Type_Connect.to_hmam P', Mod_Type_Connect.to_hmam S', Mod_Type_Connect.to_hmam Q')"
    using PSQ P'S'Q' Smith_1x2_JNF_def Smith_2x2_JNF_def 
    unfolding Smith_mxn_HMA_def Let_def by (metis case_prod_conv)
  have SNF_1x2_works': "(A::'a mat)  carrier_mat 1 2. is_SNF A (1m 1, (Smith_1x2_JNF A))" 
  proof (rule+)
    fix A'::"'a mat" assume A': "A'  carrier_mat 1 2" 
    let ?A' = "(Mod_Type_Connect.to_hmav (Matrix.row A' 0))::'a^2"    
    obtain S2 Q2 where S'Q': "(S2,Q2) = Smith_1x2 ?A'"       
      by (metis surjective_pairing)
    let ?S2 = "(Mod_Type_Connect.from_hmav S2)"
    let ?S' = "mat_of_row ?S2"
    let ?Q' = "Mod_Type_Connect.from_hmam Q2"
    have [transfer_rule]: "Mod_Type_Connect.HMA_V ?S2 S2"
      unfolding Mod_Type_Connect.HMA_V_def by auto
    have [transfer_rule]: "Mod_Type_Connect.HMA_M ?Q' Q2"
      unfolding Mod_Type_Connect.HMA_M_def by auto
    have [transfer_rule]: "Mod_Type_Connect.HMA_I 1 (1::2)"
      unfolding Mod_Type_Connect.HMA_I_def by (simp add: to_nat_1)
    have c[transfer_rule]: "Mod_Type_Connect.HMA_V ((Matrix.row A' 0)) ?A'" 
      unfolding Mod_Type_Connect.HMA_V_def 
      by (rule from_hma_to_hmav[symmetric], insert A', auto simp add: Matrix.row_def)      
    have *: "Smith_1x2_JNF A' = (?S', ?Q')" by (metis Smith_1x2_JNF_def S'Q' case_prod_conv)    
    show "is_SNF A' (1m 1, Smith_1x2_JNF A')" unfolding *
    proof (rule is_SNF_intro)
      let ?row_A' = "(Matrix.row A' 0)"
      have w: "S2 $h 1 = 0  invertible Q2  S2 = ?A' v* Q2"
        using SNF_1x2_works by (metis (mono_tags, lifting) S'Q' fst_conv prod.case_eq_if snd_conv)      
      have "?S2 $v 1 = 0" using w[untransferred] by auto      
      thus "Smith_normal_form_mat ?S'" unfolding Smith_normal_form_mat_def isDiagonal_mat_def
        by (auto simp add: less_2_cases_iff)
      have S2_Q2_A: "S2 = transpose Q2 *v ?A'" using w transpose_matrix_vector by auto      
      have S2_Q2_A': "?S2 = transpose_mat ?Q' *v ((Matrix.row A' 0))" using S2_Q2_A by transfer'      
      show "1m 1  carrier_mat (dim_row A') (dim_row A')" using A' by auto
      show "?Q'  carrier_mat (dim_col A') (dim_col A')" using A' by auto
      show "invertible_mat (1m 1)" by auto
      show "invertible_mat ?Q'" using w[untransferred] by auto
      have "?S' = A' * ?Q'" 
      proof (rule eq_matI)
        show "dim_row ?S' = dim_row (A' * ?Q')" and "dim_col ?S' = dim_col (A' * ?Q')"
          using A' by auto
        fix i j assume i: "i < dim_row (A' * ?Q')" and j: "j < dim_col (A' * ?Q')"
        have "?S' $$ (i, j) = ?S' $$ (0, j)"
          by (metis A' One_nat_def carrier_matD(1) i index_mult_mat(2) less_Suc0)
        also have "... =?S2 $v j" using j by auto
        also have "... = (transpose_mat ?Q' *v ?row_A') $v j" unfolding S2_Q2_A' by simp
        also have "... = Matrix.row (transpose_mat ?Q') j  ?row_A'"
          by (rule index_mult_mat_vec, insert j, auto)
        also have "... = Matrix.col ?Q' j  ?row_A'" using j by auto
        also have "... = ?row_A'  Matrix.col ?Q' j" 
          by (metis (no_types, lifting) Mod_Type_Connect.HMA_V_def Mod_Type_Connect.from_hmam_def 
              Mod_Type_Connect.from_hmav_def c col_def comm_scalar_prod dim_row_mat(1) vec_carrier)       
        also have "... = (A' * ?Q') $$ (0, j)" using A' j by auto
        finally show "?S' $$ (i, j) = (A' * ?Q') $$ (i, j)" using i j A' by auto
      qed
      thus "?S' = 1m 1 * A' * ?Q'" using A' by auto
    qed
  qed
  have SNF_2x2_works': "(A::'a mat)  carrier_mat 2 2. is_SNF A (Smith_2x2_JNF A)"
  proof 
    fix A'::"'a mat" assume A': "A'  carrier_mat 2 2"
    let ?A' = "Mod_Type_Connect.to_hmam A'::'a^2^2"
    obtain P2 S2 Q2 where P2S2Q2: "(P2, S2, Q2) = Smith_2x2 ?A'"
      by (metis prod_cases3)
    let ?P2 = "Mod_Type_Connect.from_hmam P2" 
    let ?S2 = "Mod_Type_Connect.from_hmam S2"
    let ?Q2 = "Mod_Type_Connect.from_hmam Q2"    
    have [transfer_rule]: "Mod_Type_Connect.HMA_M ?Q2 Q2"
      and [transfer_rule]: "Mod_Type_Connect.HMA_M ?P2 P2"
      and [transfer_rule]: "Mod_Type_Connect.HMA_M ?S2 S2"
      and [transfer_rule]: "Mod_Type_Connect.HMA_M A' ?A'"
      unfolding Mod_Type_Connect.HMA_M_def using A' by auto
    have "is_SNF A' (?P2,?S2,?Q2)"
    proof -
      have P2: "?P2  carrier_mat (dim_row A') (dim_row A')" and 
        Q2: "?Q2  carrier_mat (dim_col A') (dim_col A')" using A' by auto
      have "is_SNF_HMA ?A' (P2,S2,Q2)" using SNF_2x2_works by (simp add: P2S2Q2)
      hence "invertible P2  invertible Q2  Smith_normal_form S2  S2 = P2 ** ?A' ** Q2"
        unfolding is_SNF_HMA_def by auto
      from this[untransferred] show ?thesis using P2 Q2 unfolding is_SNF_def by auto
    qed
    thus "is_SNF A' (Smith_2x2_JNF A')" using P2S2Q2 by (metis Smith_2x2_JNF_def case_prod_conv) 
  qed  
  interpret Smith_Impl Smith_1x2_JNF Smith_2x2_JNF div_op
    using SNF_2x2_works' SNF_1x2_works' d by (unfold_locales, auto)
  have A: "?A  carrier_mat CARD('m) CARD('n)" by auto
  have "is_SNF ?A (Smith_Impl.Smith_mxn Smith_1x2_JNF Smith_2x2_JNF div_op ?A)"
    by (rule is_SNF_Smith_mxn[OF A])
  hence inv_P': "invertible_mat P'" 
    and Smith_S': "Smith_normal_form_mat S'" and inv_Q': "invertible_mat Q'" 
    and S'_P'AQ': "S' = P' * ?A * Q'" 
    and P': "P'  carrier_mat (dim_row ?A) (dim_row ?A)"
    and Q': "Q'  carrier_mat (dim_col ?A) (dim_col ?A)"
    unfolding is_SNF_def P'S'Q'[symmetric] by auto
  have S': "S'  carrier_mat (dim_row ?A) (dim_col ?A)" using P' Q' S'_P'AQ' by auto
  have [transfer_rule]: "Mod_Type_Connect.HMA_M P' P"    
  and [transfer_rule]: "Mod_Type_Connect.HMA_M S' S" 
  and [transfer_rule]: "Mod_Type_Connect.HMA_M Q' Q" 
  and [transfer_rule]: "Mod_Type_Connect.HMA_M ?A A" 
    unfolding Mod_Type_Connect.HMA_M_def using PSQ_P'S'Q'
    using from_hma_to_hmam[symmetric] P' A Q' S' by auto
  have inv_Q: "invertible Q" using inv_Q' by transfer
  moreover have Smith_S: "Smith_normal_form S" using Smith_S' by transfer
  moreover have inv_P: "invertible P" using inv_P' by transfer
  moreover have "S = P ** A ** Q" using S'_P'AQ' by transfer
  thus ?thesis using inv_Q inv_P Smith_S unfolding is_SNF_HMA_def by auto
qed
end

Theory Elementary_Divisor_Rings

(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section ‹Elementary divisor rings›

theory Elementary_Divisor_Rings
  imports           
    SNF_Algorithm
    Rings2_Extended
begin

text ‹This theory contains the definition of elementary divisor rings and Hermite rings, as 
well as the corresponding relation between both concepts. 
It also includes a complete characterization
for elementary divisor rings, by means of an \emph{if and only if}-statement.

The results presented here follows the article ``Some remarks about elementary divisor rings''
by Leonard Gillman and Melvin Henriksen.›

subsection ‹Previous definitions and basic properties of Hermite ring›

definition "admits_triangular_reduction A = 
  (U::'a::comm_ring_1 mat. U  carrier_mat (dim_col A) (dim_col A) 
   invertible_mat U  lower_triangular (A*U))"

class Hermite_ring =
  assumes "(A::'a::comm_ring_1 mat). admits_triangular_reduction A"

lemma admits_triangular_reduction_intro:
  assumes "invertible_mat (U::'a::comm_ring_1 mat)" 
    and "U  carrier_mat (dim_col A) (dim_col A)"
    and "lower_triangular (A*U)"
  shows "admits_triangular_reduction A" 
  using assms unfolding admits_triangular_reduction_def by auto

lemma OFCLASS_Hermite_ring_def:
  "OFCLASS('a::comm_ring_1, Hermite_ring_class) 
   ((A::'a::comm_ring_1 mat). admits_triangular_reduction A)"
proof 
  fix A::"'a mat"
  assume H: "OFCLASS('a::comm_ring_1, Hermite_ring_class)"
  have "A. admits_triangular_reduction (A::'a mat)"
    using conjunctionD2[OF H[unfolded Hermite_ring_class_def class.Hermite_ring_def]] by auto    
  thus "admits_triangular_reduction A" by auto
next
  assume i: "(A::'a mat. admits_triangular_reduction A)"
  show "OFCLASS('a, Hermite_ring_class)"
  proof 
    show "A::'a mat. admits_triangular_reduction A" using i by auto
  qed
qed


definition admits_diagonal_reduction::"'a::comm_ring_1 mat  bool"
  where "admits_diagonal_reduction A = (P Q. P  carrier_mat (dim_row A) (dim_row A) 
        Q  carrier_mat (dim_col A) (dim_col A) 
         invertible_mat P  invertible_mat Q 
         Smith_normal_form_mat (P * A * Q))"

lemma admits_diagonal_reduction_intro:
  assumes "P  carrier_mat (dim_row A) (dim_row A)"
    and "Q  carrier_mat (dim_col A) (dim_col A)" 
    and "invertible_mat P" and "invertible_mat Q "
    and "Smith_normal_form_mat (P * A * Q)"
  shows "admits_diagonal_reduction A" using assms unfolding admits_diagonal_reduction_def by fast

(*Lemmas for equivalence between admits_diagonal_reduction and is_SNF 
  via the existence of an algorithm*)

lemma admits_diagonal_reduction_imp_exists_algorithm_is_SNF:
  assumes "A  carrier_mat m n"
  and "admits_diagonal_reduction A"
shows "algorithm. is_SNF A (algorithm A)" 
  using assms unfolding is_SNF_def admits_diagonal_reduction_def
  by auto

lemma exists_algorithm_is_SNF_imp_admits_diagonal_reduction:
  assumes "A  carrier_mat m n"
  and "algorithm. is_SNF A (algorithm A)"
  shows "admits_diagonal_reduction A"
  using assms unfolding is_SNF_def admits_diagonal_reduction_def
  by auto

lemma admits_diagonal_reduction_eq_exists_algorithm_is_SNF:
  assumes A: "A  carrier_mat m n"
  shows "admits_diagonal_reduction A = (algorithm. is_SNF A (algorithm A))"
  using admits_diagonal_reduction_imp_exists_algorithm_is_SNF[OF A]
  using exists_algorithm_is_SNF_imp_admits_diagonal_reduction[OF A]
  by auto


lemma admits_diagonal_reduction_imp_exists_algorithm_is_SNF_all:
  assumes "((A::'a::comm_ring_1 mat)  carrier_mat m n. admits_diagonal_reduction A)" 
  shows" (algorithm. (A::'a mat)  carrier_mat m n. is_SNF A (algorithm A))"
proof -
  let ?algorithm = "λA. SOME (P, S, Q). is_SNF A (P,S,Q)"
  show ?thesis
    by (rule exI[of _ ?algorithm]) (metis (no_types, lifting) 
        admits_diagonal_reduction_imp_exists_algorithm_is_SNF assms case_prod_beta prod.collapse someI)
qed

lemma exists_algorithm_is_SNF_imp_admits_diagonal_reduction_all:
  assumes "(algorithm. (A::'a mat)  carrier_mat m n. is_SNF A (algorithm A))"
  shows "((A::'a::comm_ring_1 mat)  carrier_mat m n. admits_diagonal_reduction A)"
  using assms exists_algorithm_is_SNF_imp_admits_diagonal_reduction by blast  

 
lemma admits_diagonal_reduction_eq_exists_algorithm_is_SNF_all:
  shows "((A::'a::comm_ring_1 mat)  carrier_mat m n. admits_diagonal_reduction A) 
  = (algorithm. (A::'a mat)  carrier_mat m n. is_SNF A (algorithm A))"
  using exists_algorithm_is_SNF_imp_admits_diagonal_reduction_all
  using admits_diagonal_reduction_imp_exists_algorithm_is_SNF_all by auto


subsection ‹The class that represents elementary divisor rings›

class elementary_divisor_ring =
  assumes "(A::'a::comm_ring_1 mat). admits_diagonal_reduction A"


lemma dim_row_mat_diag[simp]: "dim_row (mat_diag n f) = n" and 
      dim_col_mat_diag[simp]: "dim_col (mat_diag n f) = n" 
  using mat_diag_dim unfolding carrier_mat_def by auto+


subsection ‹Hermite ring implies B\'ezout ring›

(*HERMITE ⟹ BEZOUT*)

text ‹To prove this fact, we make use of the alternative definition for B\'ezout rings:
each finitely generated ideal is principal›

lemma Hermite_ring_imp_Bezout_ring:
  assumes H: "OFCLASS('a::comm_ring_1, Hermite_ring_class)"
  shows " OFCLASS('a::comm_ring_1, bezout_ring_class)"
proof (rule all_fin_gen_ideals_are_principal_imp_bezout, rule+)
  fix I::"'a set" assume fin: "finitely_generated_ideal I"
  (*We take the list, put it in a 1xn matrix and then multiply it by a matrix Q that I will obtain*)
  obtain S where ig_S: "ideal_generated S = I" and fin_S: "finite S" 
    using fin unfolding finitely_generated_ideal_def by auto
  obtain xs where set_xs: "set xs = S" and d: "distinct xs" 
    using finite_distinct_list[OF fin_S] by blast
  hence length_eq_card: "length xs = card S" using distinct_card by force
  define n where "n = card S"
  define A where "A = mat_of_rows n [vec_of_list xs]"
  have A[simp]: "A  carrier_mat 1 n" unfolding A_def using mat_of_rows_carrier by auto
  have "(A::'a::comm_ring_1 mat). admits_triangular_reduction A" 
    using H unfolding OFCLASS_Hermite_ring_def by auto  
  from this obtain Q where inv_Q: "invertible_mat Q" and t_AQ: "lower_triangular (A*Q)"
    and Q[simp]: "Q  carrier_mat n n"
    unfolding admits_triangular_reduction_def using A by auto  
  have AQ[simp]: "A * Q  carrier_mat 1 n" using A Q by auto
  show "principal_ideal I"
  proof (cases "xs=[]")
  case True
    then show ?thesis
      by (metis empty_set ideal_generated_0 ideal_generated_empty ig_S principal_ideal_def set_xs)
  next
    case False
    have a: "0 < dim_row A" using A by auto
    have "0 < length xs" using False by auto  
    hence b: "0 < dim_col A" using A n_def length_eq_card by auto
    have q0: "0 < dim_col Q" by (metis A Q b carrier_matD(2))
    have n0: "0<n" using 0 < length xs length_eq_card n_def by linarith
    define d where "d = (A*Q) $$ (0,0)"
        let ?h = "(λx. THE i. xs ! i = x  i<n)"
        let ?u = "λi. xs ! i"
        have bij: "bij_betw ?h (set xs) {0..<n}" 
        proof (rule bij_betw_imageI)
          show "inj_on ?h (set xs)"
          proof -
            have "x=y" if x: "x  set xs" and y: "y  set xs"
              and xy: "(THE i. xs ! i = x  i < n) = (THE i. xs ! i = y  i < n)" for x y
            proof -
              let ?i = "(THE i. xs ! i = x  i < n)"
              let ?j = "(THE i. xs ! i = y  i < n)"
             obtain i where xs_i: "xs ! i = x  i < n" using x
                by (metis in_set_conv_nth length_eq_card n_def)
             from this have 1: "xs ! ?i = x  ?i < n"
               by (rule theI, insert d xs_i length_eq_card n_def nth_eq_iff_index_eq, fastforce)
             obtain j where xs_j: "xs ! j = y  j < n" using y
                by (metis in_set_conv_nth length_eq_card n_def)
             from this have 2: "xs ! ?j = y  ?j < n"
               by (rule theI, insert d xs_j length_eq_card n_def nth_eq_iff_index_eq, fastforce)    
             show ?thesis using 1 2 d xy by argo
           qed
           thus ?thesis unfolding inj_on_def by auto
         qed      
         show "(λx. THE i. xs ! i = x  i < n) ` set xs = {0..<n}"
         proof (auto)  
           fix xa assume xa: "xa  set xs"
           let ?i = "(THE i. xs ! i = xa  i < n)"
           obtain i where xs_i: "xs ! i = xa  i < n" using xa
             by (metis in_set_conv_nth length_eq_card n_def)
           from this have 1: "xs ! ?i = xa  ?i < n"
             by (rule theI, insert d xs_i length_eq_card n_def nth_eq_iff_index_eq, fastforce)
           thus "(THE i. xs ! i = xa  i < n) < n" by simp
         next
           fix x assume x: "x<n"
           have "xaset xs. x = (THE i. xs ! i = xa  i < n)"
             by (rule bexI[of _ "xs ! x"], rule the_equality[symmetric], insert x d) 
                (auto simp add: length_eq_card n_def nth_eq_iff_index_eq)+
           thus "x  (λx. THE i. xs ! i = x  i < n) ` set xs" unfolding image_def by auto
         qed
       qed
    have i: "ideal_generated {d} = ideal_generated S"
    proof -    
      have ideal_S_explicit: "ideal_generated S = {y. f. (iS. f i * i) = y}"
        unfolding ideal_explicit2[OF fin_S] by simp
      have "ideal_generated {d}  ideal_generated S"
      proof (rule ideal_generated_subset2, auto simp add: ideal_S_explicit)
        have n: "dim_vec (col Q 0) = n" using Q n_def by auto
        have aux: "Matrix.row A 0 $v i = xs ! i" if i: "i<n" for i
        proof -
          have i2: "i < dim_col A"
            by (simp add: A_def i)
          have "Matrix.row A 0 $v i = A $$ (0,i)" by (rule index_row(1), auto simp add: a b i2)
          also have "... = [vec_of_list xs] ! 0 $v i" 
            unfolding A_def by (rule mat_of_rows_index, auto simp add: i)
          also have "... = xs ! i"
            by (simp add: vec_of_list_index)
          finally show ?thesis .
        qed    
        let ?f = "λx. let i = (THE i. xs ! i = x  i < n) in col Q 0 $v i"
        let ?g = "(λi. xs ! i * col Q 0 $v i)"
        have "d = (A*Q) $$ (0,0)" unfolding d_def by simp 
        also have "... = Matrix.row A 0  col Q 0" by (rule index_mult_mat(1)[OF a q0])
        also have "... = (i = 0..<dim_vec (col Q 0). Matrix.row A 0 $v i * col Q 0 $v i)" 
          unfolding scalar_prod_def by simp
        also have "... = (i = 0..<n. Matrix.row A 0 $v i * col Q 0 $v i)" unfolding n by auto
        also have "... = (i = 0..<n. xs ! i * col Q 0 $v i)" 
          by (rule sum.cong, auto simp add: aux)
        also have "... = (x  set xs. ?g (?h x))"
          by (rule sum.reindex_bij_betw[symmetric, OF bij])
        also have "... = (x  set xs. ?f x * x)"
        proof (rule sum.cong, auto simp add: Let_def)
          fix x assume x: "x  set xs"
          let ?i = "(THE i. xs ! i = x  i < n)"
          obtain i where xs_i: "xs ! i = x  i < n"
            by (metis in_set_conv_nth x length_eq_card n_def)
          from this have "xs ! ?i = x  ?i < n"
            by (rule theI, insert d xs_i length_eq_card n_def nth_eq_iff_index_eq, fastforce)       
          thus "xs ! ?i * col Q 0 $v ?i = col Q 0 $v ?i * x" by auto
        qed
        also have "... = (x  S. ?f x * x)" using set_xs by auto
        finally show "f. (iS. f i * i) = d" by auto
      qed
      moreover have "ideal_generated S  ideal_generated {d}"
      proof 
        fix x assume x: "x  ideal_generated S" thm Matrix.diag_mat_def
        hence x_xs: "x  ideal_generated (set xs)" by (simp add: set_xs)
        from this obtain f where f: "(i(set xs). f i * i) = x" using x ideal_explicit2 by auto
        define B where "B = Matrix.vec n (λi. f (A $$ (0,i)))"
        have B: "B  carrier_vec n" unfolding B_def by auto
        have "(A *v B) $v 0 = Matrix.row A 0  B" by (rule index_mult_mat_vec[OF a])
        also have "... = sum (λi. f (A $$ (0,i)) * A $$ (0,i)) {0..<n}"
          unfolding B_def Matrix.row_def scalar_prod_def by (rule sum.cong, auto simp add: A_def)
        also have "... = sum (λi. f i * i) (set xs)"
        proof (rule sum.reindex_bij_betw)
          have 1: "inj_on (λx. A $$ (0, x)) {0..<n}"
          proof (unfold inj_on_def, auto)
            fix x y assume x: "x < n" and y: "y < n" and xy: "A $$ (0, x) = A $$ (0, y)"
            have "A $$ (0,x) =  [vec_of_list xs] ! 0 $v x" 
              unfolding A_def by (rule mat_of_rows_index, insert x y, auto)
            also have "... = xs ! x" using x by (simp add: vec_of_list_index)
            finally have 1: "A $$ (0,x) = xs ! x" .
            have "A $$ (0,y) =  [vec_of_list xs] ! 0 $v y" 
              unfolding A_def by (rule mat_of_rows_index, insert x y, auto)
            also have "... = xs ! y" using y by (simp add: vec_of_list_index)
            finally have 2: "A $$ (0,y) = xs ! y" .
            show "x = y" using 1 2 x y d length_eq_card n_def nth_eq_iff_index_eq xy by fastforce
          qed
          have 2: "A $$ (0, xa)  set xs" if xa: "xa < n" for xa
          proof -
            have "A $$ (0,xa) =  [vec_of_list xs] ! 0 $v xa" 
              unfolding A_def by (rule mat_of_rows_index, insert xa, auto)
            also have "... = xs ! xa" using xa by (simp add: vec_of_list_index)
            finally show ?thesis using xa by (simp add: length_eq_card n_def)
          qed
          have 3: "x  (λx. A $$ (0, x)) ` {0..<n}" if x: "x set xs" for x
          proof -
            obtain i where xs: "xs ! i = x  i < n"
              by (metis in_set_conv_nth length_eq_card n_def x)
            have "A $$ (0,i) = [vec_of_list xs] ! 0 $v i" 
              unfolding A_def by (rule mat_of_rows_index, insert xs, auto)
            also have "... = xs ! i" using xs by (simp add: vec_of_list_index) 
            finally show ?thesis using xs unfolding image_def by auto
          qed
          show "bij_betw (λx. A $$ (0, x)) {0..<n} (set xs)" using 1 2 3 unfolding bij_betw_def by auto
        qed
        finally have AB00_sum: "(A *v B) $v 0 = sum (λi. f i * i) (set xs)" by auto
        hence AB_00_x: "(A *v B) $v 0 = x" using f by auto
        obtain Q' where QQ': "inverts_mat Q Q'" 
          and Q'Q: "inverts_mat Q' Q" and Q': "Q'  carrier_mat n n"
          by (rule obtain_inverse_matrix[OF Q inv_Q], auto) 
        have eq: "A = (A*Q)*Q'" using QQ' unfolding inverts_mat_def
          by (metis A Q Q' assoc_mult_mat carrier_matD(1) right_mult_one_mat)        
        let ?g = "λi. Matrix.row (A * Q) 0 $v i * (Matrix.row Q' i  B)"
        have sum0: "(i = 1..<n. ?g i) = 0"
        proof (rule sum.neutral, rule)
          fix x assume x: "x  {1..<n}"
          hence "Matrix.row (A * Q) 0 $v x = 0" using t_AQ unfolding lower_triangular_def
            by (auto, metis Q Suc_le_lessD a carrier_matD(2) index_mult_mat(2,3) index_row(1))
          thus "Matrix.row (A * Q) 0 $v x * (Matrix.row Q' x  B) = 0" by simp
        qed
        have set_rw: "{0..<n} - {0} = {1..<n}"
          by (simp add: atLeast0LessThan atLeast1_lessThan_eq_remove0) 
        have mat_rw: "(A*Q*Q')*v B = A*Q*v(Q' *v B)"
          by (rule assoc_mult_mat_vec, insert Q Q' B AQ, auto)
        from eq have "A *vB = (A*Q)*v(Q'*v B)" using mat_rw by auto
        from this have "(A *v B) $v 0 = (A * Q *v (Q' *v B)) $v 0" by auto
        also have "... =  Matrix.row (A*Q) 0  (Q' *v B)"
          by (rule index_mult_mat_vec, insert a B_def n0, auto)
        also have "... =  (i = 0..<n. ?g i)" using Q' by (auto simp add: scalar_prod_def)
        also have "... = ?g 0 + (i  {0..<n} - {0}. ?g i)"
          by (metis (no_types, lifting) Q atLeast0LessThan carrier_matD(2) finite_atLeastLessThan 
              lessThan_iff q0 sum.remove)        
        also have "... = ?g 0 + (i = 1..<n. ?g i)" using set_rw by simp        
        also have "... = ?g 0" using sum0 by auto
        also have "... = d * (Matrix.row Q' 0  B)" by (simp add: a d_def q0)
        finally show "x  ideal_generated {d}" using AB_00_x unfolding ideal_generated_singleton 
          using mult.commute by auto
      qed
      ultimately show ?thesis by auto
    qed
    thus "principal_ideal I" unfolding principal_ideal_def ig_S by blast
  qed
qed

subsection ‹Elementary divisor ring implies Hermite ring›

context
  assumes "SORT_CONSTRAINT('a::comm_ring_1)"
begin


lemma triangularizable_m0:
assumes A: "A  carrier_mat m 0" 
shows "U. U  carrier_mat 0 0  invertible_mat U  lower_triangular (A * U)"
  using A unfolding lower_triangular_def carrier_mat_def invertible_mat_def inverts_mat_def  
  by auto (metis gr_implies_not0 index_one_mat(2) index_one_mat(3) right_mult_one_mat')

lemma triangularizable_0n:
assumes A: "A  carrier_mat 0 n" 
shows "U. U  carrier_mat n n  invertible_mat U  lower_triangular (A * U)"
  using A unfolding lower_triangular_def carrier_mat_def invertible_mat_def inverts_mat_def  
  by auto (metis index_one_mat(2) index_one_mat(3) right_mult_one_mat')


(*To show this, we have to prove that P is a matrix of one element, which is a unit.*)
lemma diagonal_imp_triangular_1x2:
  assumes A: "A  carrier_mat 1 2" and d: "admits_diagonal_reduction (A::'a mat)"
  shows "admits_triangular_reduction A"
proof -
  obtain P Q where P: "P  carrier_mat (dim_row A) (dim_row A)"
  and Q: "Q  carrier_mat (dim_col A) (dim_col A)" 
  and inv_P: "invertible_mat P" and inv_Q: "invertible_mat Q"
  and SNF: "Smith_normal_form_mat (P * A * Q)"
    using d unfolding admits_diagonal_reduction_def by blast
  have "(P * A * Q) = P * (A * Q)" using P Q assoc_mult_mat by blast
  also have "... = P $$ (0,0) m (A * Q)" by (rule smult_mat_mat_one_element, insert P A Q, auto)
  also have "... = A * (P $$ (0,0) m Q)" using Q by auto
  finally have eq: "(P * A * Q) = A * (P $$ (0,0) m Q)" .
  have inv: "invertible_mat (P $$ (0,0) m Q)"
  proof -
    have d: "Determinant.det P = P $$ (0, 0)" by (rule determinant_one_element, insert P A, auto)
    from this have P_dvd_1: "P $$ (0, 0) dvd 1" 
      using invertible_iff_is_unit_JNF[OF P] using inv_P by auto
    have Q_dvd_1: "Determinant.det Q dvd 1" using inv_Q invertible_iff_is_unit_JNF[OF Q] by simp
    have "Determinant.det (P $$ (0, 0) m Q) =  P $$ (0, 0) ^ dim_col Q * Determinant.det Q" 
      unfolding det_smult by auto
    also have "... dvd 1" using P_dvd_1 Q_dvd_1 unfolding is_unit_mult_iff
      by (metis dvdE dvd_mult_left one_dvd power_mult_distrib power_one)
    finally have det: "(Determinant.det (P $$ (0, 0) m Q) dvd 1)" .
    have PQ: "P $$ (0,0) m Q  carrier_mat 2 2" using A P Q by auto
    show ?thesis using invertible_iff_is_unit_JNF[OF PQ] det by auto
  qed
  moreover have "lower_triangular (A * (P $$ (0,0) m Q))" unfolding lower_triangular_def using SNF eq
    unfolding Smith_normal_form_mat_def isDiagonal_mat_def by auto
  moreover have "(P $$ (0,0) m Q)  carrier_mat (dim_col A) (dim_col A)" using P Q A by auto
  ultimately show ?thesis unfolding admits_triangular_reduction_def by auto
qed

lemma triangular_imp_diagonal_1x2:
assumes A: "A  carrier_mat 1 2" and t: "admits_triangular_reduction (A::'a mat)"
shows "admits_diagonal_reduction A"
proof -
 obtain U where U: "U  carrier_mat (dim_col A) (dim_col A)"  
  and inv_U: "invertible_mat U" and AU: "lower_triangular (A * U)" 
   using t unfolding admits_triangular_reduction_def by blast
  have SNF_AU: "Smith_normal_form_mat (A * U)"
    using AU A unfolding Smith_normal_form_mat_def lower_triangular_def isDiagonal_mat_def by auto
  have "A * U = (1m 1) * A * U" using A by auto
  hence SNF: "Smith_normal_form_mat ((1m 1) * A * U)" using SNF_AU by auto
  moreover have "invertible_mat (1m 1)"
    using invertible_mat_def inverts_mat_def by fastforce
  ultimately show ?thesis using inv_U unfolding admits_diagonal_reduction_def
    by (smt U assms(1) carrier_matD(1) one_carrier_mat)
qed


lemma triangular_eq_diagonal_1x2:
 "(Acarrier_mat 1 2. admits_triangular_reduction (A::'a mat)) 
  = (Acarrier_mat 1 2. admits_diagonal_reduction (A::'a mat))"
  using triangular_imp_diagonal_1x2 diagonal_imp_triangular_1x2 by auto


lemma admits_triangular_mat_1x1:
  assumes A: "A  carrier_mat 1 1"
  shows "admits_triangular_reduction (A::'a mat)"
  by (rule admits_triangular_reduction_intro[of "1m 1"], insert A,
      auto simp add: admits_triangular_reduction_def  lower_triangular_def)


lemma admits_diagonal_mat_1x1:
  assumes A: "A  carrier_mat 1 1"
  shows "admits_diagonal_reduction (A::'a mat)"
  by (rule admits_diagonal_reduction_intro[of "(1m 1)" _ "(1m 1)"], 
      insert A, auto simp add: Smith_normal_form_mat_def isDiagonal_mat_def)


lemma admits_diagonal_imp_admits_triangular_1xn:
  assumes a: "Acarrier_mat 1 2. admits_diagonal_reduction (A::'a mat)"
  shows "Acarrier_mat 1 n. admits_triangular_reduction (A::'a mat)"
proof 
  fix A::"'a mat" assume A: "A  carrier_mat 1 n"  
  have "U. U  carrier_mat (dim_col A) (dim_col A) 
     invertible_mat U  lower_triangular (A * U)" (*Zeros above the diagonal*)
    using A
  proof (induct n arbitrary: A rule: less_induct)
    case (less n)
    note A = less.prems(1)
    show ?case
    proof (cases "n=0")
      case True
      then show ?thesis using triangularizable_m0 triangularizable_0n less.prems by auto
    next
      case False note nm_not_0 = False
      from this have n_not_0: "n  0" by auto
      show ?thesis        
      proof (cases "n>2")
        case False note n_less_2 = False
        show ?thesis using admits_triangular_mat_1x1 a diagonal_imp_triangular_1x2 
          unfolding admits_triangular_reduction_def
          by (metis (full_types) admits_triangular_mat_1x1 Suc_1 admits_triangular_reduction_def 
              less(2) less_Suc_eq less_one linorder_neqE_nat n_less_2 nm_not_0 triangular_eq_diagonal_1x2)
      next
        case True note n_ge_2 = True            
        let ?B = "mat_of_row (vec_last (Matrix.row A 0) (n - 1))"
        have "V. V carrier_mat (dim_col ?B) (dim_col ?B) 
         invertible_mat V  lower_triangular (?B * V)"
        proof (rule less.hyps)     
          show "n-1 < n" using n_not_0 by auto           
          show "mat_of_row (vec_last (Matrix.row A 0) (n - 1))  carrier_mat 1 (n - 1)" 
            using A by simp
        qed
        from this obtain V where inv_V: "invertible_mat V" and BV: "lower_triangular (?B * V)" 
          and V': "V  carrier_mat (dim_col ?B) (dim_col ?B)"
          by fast  
        have V: "V  carrier_mat (n-1) (n-1)" using V' by auto
        have BV_0: "j  {1..<n-1}. (?B * V) $$ (0,j) = 0"
          by (rule, rule lower_triangular_index[OF BV], insert V, auto)
        define b where "b = (?B * V) $$ (0,0)"
        define a where "a = A $$ (0,0)"          
        define ab::"'a mat" where "ab = Matrix.mat 1 2 (λ(i,j). if i=0  j=0 then a else b)"
        have ab[simp]: "ab  carrier_mat 1 2" unfolding ab_def by simp
        hence "admits_diagonal_reduction ab" using a by auto
        hence "admits_triangular_reduction ab" using diagonal_imp_triangular_1x2[OF ab] by auto
        from this obtain W where inv_W: "invertible_mat W" and ab_W: "lower_triangular (ab * W)"
          and W: "W  carrier_mat 2 2"
          unfolding admits_triangular_reduction_def using ab by auto
        have id_n2_carrier[simp]: "1m (n-2)  carrier_mat (n-2) (n-2)" by auto
        define U where "U = (four_block_mat (1m 1) (0m 1 (n-1)) (0m (n-1) 1) V) * 
                                (four_block_mat W (0m 2 (n-2)) (0m (n-2) 2) (1m (n-2)))"
        let ?U1 = "four_block_mat (1m 1) (0m 1 (n-1)) (0m (n-1) 1) V"
        let ?U2 = "four_block_mat W (0m 2 (n-2)) (0m (n-2) 2) (1m (n-2))"
        have U1[simp]: "?U1 carrier_mat n n" using four_block_carrier_mat[OF _ V] nm_not_0
          by fastforce
        have U2[simp]: "?U2 carrier_mat n n" using four_block_carrier_mat[OF W id_n2_carrier]              
          by (metis True add_diff_inverse_nat less_imp_add_positive not_add_less1)
        have U[simp]: "U  carrier_mat n n" unfolding U_def using U1 U2 by auto
        moreover have inv_U: "invertible_mat U"
        proof -
          have "invertible_mat ?U1"
            by (metis U1 V det_four_block_mat_lower_left_zero_col det_one inv_V 
                invertible_iff_is_unit_JNF more_arith_simps(5) one_carrier_mat zero_carrier_mat)
          moreover have "invertible_mat ?U2"
          proof -
            have "Determinant.det ?U2 = Determinant.det W"
              by (rule det_four_block_mat_lower_right_id, insert less.prems W n_ge_2, auto)
            also have " ... dvd 1"
              using W inv_W invertible_iff_is_unit_JNF by auto
            finally show ?thesis using invertible_iff_is_unit_JNF[OF U2] by auto
          qed
          ultimately show ?thesis
            using U1 U2 U_def invertible_mult_JNF by blast
        qed
        moreover have "lower_triangular (A*U)"
        proof -            
          let ?A = "Matrix.mat 1 n (λ(i,j). if j = 0 then a else if j=1 then b else 0)"
          let ?T = "Matrix.mat 1 n (λ(i,j). if j = 0 then (ab*W) $$ (0,0) else 0)"
          have "A*?U1 = ?A" 
          proof (rule eq_matI)
            fix i j assume i: "i<dim_row ?A" and j: "j<dim_col ?A"
            have i0: "i=0" using i by auto
            let ?f = "λ i. A $$ (0, i) * 
            (if i = 0 then if j < 1 then 1m (1) $$ (i, j) else 0m (1) (n - 1) $$ (i, j - 1)
             else if j < 1 then 0m (n - 1) (1) $$ (i - 1, j) else V $$ (i - 1, j - 1))"
            have "(A*?U1) $$ (i,j) = Matrix.row A i  col ?U1 j" 
              by (rule index_mult_mat, insert i j A V, auto)           
            also have "... =  (i = 0..<n. ?f i)"
              using i j A V unfolding scalar_prod_def 
              by auto (unfold index_one_mat, insert One_nat_def, presburger)
            also have "... = ?A $$ (i,j)"
            proof (cases "j=0")
              case True
              have rw0: "sum ?f {1..<n} = 0" by (rule sum.neutral, insert True, auto)  
              have set_rw: "{0..<n} = insert 0 {1..<n}" using n_ge_2 by auto
              hence "sum ?f {0..<n} = ?f 0 + sum ?f {1..<n}" by auto
              also have "... = ?f 0" unfolding rw0 by simp
              also have "... = a" using True unfolding a_def by simp
              also have "... = ?A $$ (i,j)" using True i j by auto
              finally show ?thesis .
            next
              case False note j_not_0 = False
              have rw_simp: "Matrix.row (mat_of_row (vec_last (Matrix.row A 0) (n - 1))) 0 
                  = (vec_last (Matrix.row A 0) (n - 1))" unfolding Matrix.row_def by auto               
              let ?g = "λi. A $$ (0, i) * V $$ (i - 1, j - 1)"
              let ?h = "λi. A $$ (0, i+1) * V $$ (i, j - 1)"
              have f0: "?f 0 = 0" using j_not_0 j by auto
              have set_rw2: "(λi. i+1)`{0..<n-1} = {1..<n}" 
                unfolding image_def using Suc_le_D by fastforce                
              have set_rw: "{0..<n} = insert 0 {1..<n}" using n_ge_2 by auto
              hence "sum ?f {0..<n} = ?f 0 + sum ?f {1..<n}" by auto
              also have "... = sum ?f {1..<n}" using f0 by simp
              also have "... = sum ?g {1..<n}" by (rule sum.cong, insert j_not_0,  auto)
              also have "... = sum ?g ((λi. i+1)`{0..<n-1})" using set_rw2 by simp
              also have "... = sum (?g  (λi. i+1)) {0..<n-1}" 
                by (rule sum.reindex, unfold inj_on_def, auto)
              also have "... = sum ?h {0..<n-1}" by (rule sum.cong, auto)
              also have "... = Matrix.row ?B 0  col V (j-1)" unfolding scalar_prod_def 
              proof (rule sum.cong)
                fix x assume x: "x  {0..<dim_vec (col V (j - 1))}"
                have "Matrix.row ?B 0 $v x = ?B $$ (0,x)" by (rule index_row, insert x V, auto)
                also have "... = (vec_last (Matrix.row A 0) (n - 1)) $v x" 
                  by (rule mat_of_row_index, insert x V, auto)
                also have "... = A $$ (0, x + 1)"
                  by (smt Suc_less_eq V add.right_neutral add_Suc_right add_diff_cancel_right' 
                      add_diff_inverse_nat atLeastLessThan_iff carrier_matD(1) carrier_matD(2) 
                      dim_col index_row(1) index_row(2) index_vec less.prems less_Suc0 n_not_0 
                      plus_1_eq_Suc vec_last_def x)
                finally have "Matrix.row ?B 0 $v x = A $$ (0, x + 1)" .
                moreover have "col V (j - 1) $v x = V $$ (x, j - 1)" using V j x by auto
                ultimately show "A $$ (0, x + 1) * V $$ (x, j - 1) 
                    = Matrix.row ?B 0 $v x * col V (j - 1) $v x" by simp
              qed (insert V j_not_0, auto)                  
              also have "... = (?B*V) $$ (0,j-1)" 
                by (rule index_mult_mat[symmetric], insert V j False, auto)
              also have "... = ?A $$ (i, j)" 
                by (cases "j=1", insert False V j i0 BV_0 b_def, auto simp add: Suc_leI)                               
              finally show ?thesis .
            qed
            finally show "(A*?U1) $$ (i,j) = ?A $$ (i,j)" .
          next
            show "dim_row (A*?U1) = dim_row ?A" using A by auto
            show "dim_col (A*?U1) = dim_col ?A" using U1 by auto          
          qed         
          also have "... * ?U2 = ?T"
          proof -
            let ?A1.0 = "ab"
            let ?B1.0 = "Matrix.mat 1 (n-2) (λ(i,j). 0)"
            let ?C1.0 = "Matrix.mat 0 2 (λ(i,j). 0)"
            let ?D1.0 = "Matrix.mat 0 (n-2) (λ(i,j). 0)"
            let ?B2.0 = "(0m 2 (n - 2))"
            let ?C2.0 = "(0m (n - 2) 2)"
            let ?D2.0 = "1m (n - 2)"
            have A_eq: "?A = four_block_mat ?A1.0 ?B1.0 ?C1.0 ?D1.0" 
              by (rule eq_matI, insert ab_def n_ge_2, auto)
            hence "?A * ?U2 = four_block_mat ?A1.0 ?B1.0 ?C1.0 ?D1.0 * ?U2" by simp
            also have "... = four_block_mat (?A1.0 * W + ?B1.0 * ?C2.0) 
              (?A1.0 * ?B2.0 + ?B1.0 * ?D2.0) (?C1.0 * W + ?D1.0 * ?C2.0) 
              (?C1.0 * ?B2.0 + ?D1.0 * ?D2.0)"
              by (rule mult_four_block_mat, auto simp add: W ab_def)
            also have "... = four_block_mat (?A1.0 * W) (?B1.0) (?C1.0) (?D1.0)"
              by (rule cong_four_block_mat, insert W ab_def, auto)
            also have "... = ?T"
              by (rule eq_matI, insert W n_ge_2 ab_def ab_W, auto simp add: lower_triangular_def)
            finally show ?thesis .                              
          qed
          finally have "A * U = ?T" 
            using assoc_mult_mat[OF _ U1 U2] less.prems unfolding U_def by auto
          moreover have "lower_triangular ?T" unfolding lower_triangular_def by simp
          ultimately show ?thesis by simp
        qed
        ultimately show ?thesis using A U by blast
      qed
    qed
  qed
  from this show "admits_triangular_reduction A" unfolding admits_triangular_reduction_def by simp
qed

lemma admits_diagonal_imp_admits_triangular:
  assumes a: "Acarrier_mat 1 2. admits_diagonal_reduction (A::'a mat)"
  shows "A. admits_triangular_reduction (A::'a mat)"
proof 
  fix A::"'a mat"
  obtain m n where A: "A  carrier_mat m n" by auto
  have "U. U  carrier_mat n n  invertible_mat U  lower_triangular (A * U)" (*Zeros above the diagonal*)
    using A
  proof (induct n arbitrary: m A rule: less_induct)
    case (less n)
    note A = less.prems(1)
    show ?case
    proof (cases "n=0  m=0")
      case True
      then show ?thesis using triangularizable_m0 triangularizable_0n less.prems by auto
    next
      case False note nm_not_0 = False
      from this have m_not_0: "m  0" and n_not_0: "n  0" by auto    
      show ?thesis        
      proof (cases "m = 1")
        case True note m1 = True
        show ?thesis using admits_diagonal_imp_admits_triangular_1xn A m1 a 
          unfolding admits_triangular_reduction_def by blast
      next
        case False note m_not_1 = False
          (* The article says "Right-multiply A by a unimodular matrix V which reduces the first row.
           To do that, I use the first case of the induction (m=1) to reduce the first row. 
           With lemma mult_eq_first_row I will show that A*V reduces the first row.
        *)
        show ?thesis 
        proof (cases "n=1")
          case True
          thus ?thesis using invertible_mat_zero lower_triangular_def
            by (metis carrier_matD(2) det_one gr_implies_not0 invertible_iff_is_unit_JNF less(2) 
                less_one one_carrier_mat right_mult_one_mat')
        next
          case False note n_not_1 = False                  
          let ?first_row = "mat_of_row (Matrix.row A 0)"
          have first_row: "?first_row  carrier_mat 1 n" using less.prems by auto
          have m1: "m>1" using m_not_1 m_not_0 by linarith
          have n1: "n>1" using n_not_1 n_not_0 by linarith 
          obtain V where lt_first_row_V: "lower_triangular (?first_row * V)"
            and inv_V: "invertible_mat V" and V: "V  carrier_mat n n"
            (*Using the other induction case*)
            using admits_diagonal_imp_admits_triangular_1xn a first_row 
            unfolding admits_triangular_reduction_def by blast
          have AV: "A*V  carrier_mat m n" using V less by auto
          have dim_row_AV: "dim_row (A * V) = 1 + (m-1)" using m1 AV by auto
          have dim_col_AV: "dim_col (A * V) = 1 + (n-1)" using n1 AV by fastforce
          have reduced_first_row: "Matrix.row (?first_row * V) 0 = Matrix.row (A * V) 0"  
            by (rule mult_eq_first_row, insert first_row m1 less.prems, auto)
          obtain a zero B C where split: "split_block (A*V) 1 1 = (a, zero, B, C)"          
            using prod_cases4 by blast
          have a: "a  carrier_mat 1 1" and zero: "zero  carrier_mat 1 (n-1)" and
            B: "B  carrier_mat (m-1) 1" and C: "C  carrier_mat (m-1) (n-1)"
            by (rule split_block[OF split dim_row_AV dim_col_AV])+
          have AV_block: "A*V = four_block_mat a zero B C"
            by (rule split_block[OF split dim_row_AV dim_col_AV])
          have "W. W carrier_mat (n-1) (n-1)  invertible_mat W  lower_triangular (C*W)" 
            by (rule less.hyps, insert n1 C, auto)        
          from this obtain W where inv_W: "invertible_mat W" and lt_CW: "lower_triangular (C*W)" 
            and W: "W  carrier_mat (n-1) (n-1)" by blast
          let ?W2 = "four_block_mat (1m 1) (0m 1 (n-1)) (0m (n-1) 1) W"
          have W2: "?W2  carrier_mat n n" using V W dim_col_AV by auto
          have "Determinant.det ?W2 = Determinant.det (1m 1) * Determinant.det W" 
            by (rule det_four_block_mat_lower_left_zero_col[OF _ _ _ W], auto)
          hence det_W2: "Determinant.det ?W2 = Determinant.det W" by auto
          hence inv_W2: "invertible_mat ?W2"
            by (metis W four_block_carrier_mat inv_W invertible_iff_is_unit_JNF one_carrier_mat)
          have inv_V_W2: "invertible_mat (V * ?W2)" using inv_W2 inv_V V W2 invertible_mult_JNF by blast
          have "lower_triangular (A*V*?W2)"
          proof -
            let ?T = "(four_block_mat a (0m 1 (n-1)) B (C * W))"
            have zero_eq: "zero = 0m 1 (n-1)"
            proof (rule eq_matI)
              show 1: "dim_row zero = dim_row (0m 1 (n - 1))" and 2: "dim_col zero = dim_col (0m 1 (n - 1))"
                using zero by auto
              fix i j assume i: "i < dim_row (0m 1 (n - 1))" and j: "j < dim_col (0m 1 (n - 1))"
              have i0: "i=0" using i by auto            
              have "0 = Matrix.row (?first_row * V) 0 $v (j+1)"
                using lt_first_row_V j unfolding lower_triangular_def
                by (metis Suc_eq_plus1 carrier_matD(2) index_mult_mat(2,3) index_row(1) less_diff_conv
                    mat_of_row_dim(1) zero zero_less_Suc zero_less_one_class.zero_less_one V 2)
              also have "... = Matrix.row (A*V) 0 $v (j+1)" by (simp add: reduced_first_row)
              also have "... = (A*V) $$ (i, j+1)" using V dim_row_AV i0 j by auto
              also have "... = four_block_mat a zero B C $$ (i, j+1)" by (simp add: AV_block)
              also have "... = (if i < dim_row a then if (j+1) < dim_col a 
              then a $$ (i, (j+1)) else zero $$ (i, (j+1) - dim_col a) else if (j+1) < dim_col a
              then B $$ (i - dim_row a, (j+1)) else C $$ (i - dim_row a, (j+1) - dim_col a))"               
                by (rule index_mat_four_block, insert a zero i j C, auto)
              also have "... = zero $$ (i, (j+1) - dim_col a)" using a zero i j C by auto
              also have "... = zero $$ (i, j)" using a i by auto
              finally show "zero $$ (i, j) = 0m 1 (n - 1) $$ (i, j)" using i j by auto
            qed
            have rw1: "a * (1m 1) + zero * (0m (n-1) 1) = a" using a zero by auto
            have rw2: "a * (0m 1 (n-1)) + zero * W = 0m 1 (n-1)" using a zero zero_eq W by auto
            have rw3: "B * (1m 1) + C * (0m (n-1) 1) = B" using B C by auto
            have rw4: "B * (0m 1 (n-1)) + C * W = C * W" using B C W by auto
            have "A*V = four_block_mat a zero B C" by (rule AV_block)
            also have "... * ?W2 = four_block_mat (a * (1m 1) + zero * (0m (n-1) 1)) 
          (a * (0m 1 (n-1)) + zero * W) (B * (1m 1) + C * (0m (n-1) 1))
          (B * (0m 1 (n-1)) + C * W)" by (rule mult_four_block_mat[OF a zero B C], insert W, auto)
            also have "... = ?T" using rw1 rw2 rw3 rw4 by simp
            finally have AVW2: "A*V * ?W2 = ..." .
            moreover have "lower_triangular ?T" 
              using lt_CW unfolding lower_triangular_def using a zero B C W
              by (auto, metis (full_types) Suc_less_eq Suc_pred basic_trans_rules(19))
            ultimately show ?thesis by simp
          qed
          then show ?thesis using inv_V_W2 V W2 less.prems
            by (smt assoc_mult_mat mult_carrier_mat)
        qed
      qed
    qed
  qed
  thus "admits_triangular_reduction A" using A unfolding admits_triangular_reduction_def by simp
qed

corollary admits_diagonal_imp_admits_triangular':
  assumes a: "A. admits_diagonal_reduction (A::'a mat)"
  shows "A. admits_triangular_reduction (A::'a mat)"
  using admits_diagonal_imp_admits_triangular assms by blast


lemma admits_triangular_reduction_1x2:
  assumes "A::'a mat. A  carrier_mat 1 2  admits_triangular_reduction A"
  shows "C::'a mat. admits_triangular_reduction C" 
  using admits_diagonal_imp_admits_triangular assms triangular_eq_diagonal_1x2 by auto  

 
lemma Hermite_ring_OFCLASS:
 assumes "A  carrier_mat 1 2. admits_triangular_reduction (A::'a mat)"
 shows "OFCLASS('a, Hermite_ring_class)"
proof
  show "A::'a mat. admits_triangular_reduction A" 
    by (rule admits_diagonal_imp_admits_triangular[OF assms[unfolded triangular_eq_diagonal_1x2]])     
qed

lemma Hermite_ring_OFCLASS':
 assumes "A  carrier_mat 1 2.admits_diagonal_reduction (A::'a mat)"
 shows "OFCLASS('a, Hermite_ring_class)"
proof
  show "A::'a mat. admits_triangular_reduction A" 
    by (rule admits_diagonal_imp_admits_triangular[OF assms])     
qed

lemma theorem3_part1:
  assumes T: "(a b::'a.  a1 b1 d. a = a1*d  b = b1*d 
     ideal_generated {a1,b1} = ideal_generated {1})"
  shows "A::'a mat. admits_triangular_reduction A"
proof (rule admits_triangular_reduction_1x2, rule allI, rule impI)
  fix A::"'a mat"
  assume A: "A  carrier_mat 1 2"
  let ?a = "A $$ (0,0)"
  let ?b = "A $$ (0,1)"
  obtain a1 b1 d where a: "?a = a1*d" and b: "?b = b1*d" 
    and i: "ideal_generated {a1,b1} = ideal_generated {1}" 
    using T by blast
  obtain s t where sa1tb1:"s*a1+t*b1=1" using ideal_generated_pair_exists_pq1[OF i[simplified]] by blast
  let ?Q = "Matrix.mat 2 2 (λ(i,j). if i = 0  j = 0 then s else
                                    if  i = 0  j = 1 then -b1 else
                                    if  i = 1  j = 0 then t else a1)"
  have Q: "?Q  carrier_mat 2 2" by auto
  have det_Q: "Determinant.det ?Q = 1" unfolding det_2[OF Q] 
    using sa1tb1 by (simp add: mult.commute)
  hence inv_Q: "invertible_mat ?Q" using invertible_iff_is_unit_JNF[OF Q] by auto
  have lower_AQ: "lower_triangular (A*?Q)" 
  proof -
    have "Matrix.row A 0 $v Suc 0 * a1 = Matrix.row A 0 $v 0 * b1" if j2: "j<2" and j0: "0<j" for j
      by (metis A One_nat_def a b carrier_matD(1) carrier_matD(2) index_row(1) lessI 
          more_arith_simps(11) mult.commute numeral_2_eq_2 pos2)
    thus ?thesis unfolding lower_triangular_def using A 
      by (auto simp add: scalar_prod_def sum_two_rw)
  qed
  show "admits_triangular_reduction A" 
    unfolding admits_triangular_reduction_def using lower_AQ inv_Q Q A by force    
qed


lemma theorem3_part2:
  assumes 1: "A::'a mat. admits_triangular_reduction A"
  shows "a b::'a.  a1 b1 d. a = a1*d  b = b1*d  ideal_generated {a1,b1} = ideal_generated {1}"
proof (rule allI)+
  fix a b::'a
  let ?A = "Matrix.mat 1 2 (λ(i,j). if i = 0  j = 0 then a else b)"
  obtain Q where AQ: "lower_triangular (?A*Q)" and inv_Q: "invertible_mat Q"
    and Q: "Q  carrier_mat 2 2"
    using 1 unfolding admits_triangular_reduction_def by fastforce
  hence [simp]: "dim_col Q = 2" and [simp]: "dim_row Q = 2" by auto
  let ?s = "Q $$ (0,0)"
  let ?t = "Q $$ (1,0)"
  let ?a1 = "Q $$ (1,1)"
  let ?b1 = "-(Q $$ (0,1))"
  let ?d = "(?A*Q) $$ (0,0)"
  have ab1_ba1: "a*?b1 = b*?a1"
  proof -     
    have  "(?A*Q) $$ (0,1) =  (i = 0..<2. (if i = 0 then a else b) * Q $$ (i, Suc 0))"
      unfolding times_mat_def col_def scalar_prod_def by auto
    also have "... = (i  {0,1}. (if i = 0 then a else b) * Q $$ (i, Suc 0))" 
      by (rule sum.cong, auto)
    also have "... = - a*?b1 + b*?a1" by auto
    finally have "(?A*Q) $$ (0,1) = - a*?b1 + b*?a1" by simp
    moreover have "(?A*Q) $$ (0,1) = 0" using AQ unfolding lower_triangular_def by auto  
    ultimately show ?thesis
      by (metis add_left_cancel more_arith_simps(3) more_arith_simps(7))    
  qed
  have sa_tb_d: "?s*a+?t*b = ?d"
  proof -
    have "?d = (i = 0..<2. (if i = 0 then a else b) * Q $$ (i, 0))"
      unfolding times_mat_def col_def scalar_prod_def by auto
    also have "... = (i  {0,1}. (if i = 0 then a else b) * Q $$ (i, 0))" by (rule sum.cong, auto)
    also have "... = ?s*a+?t*b" by auto
    finally show ?thesis by simp
  qed
  have det_Q_dvd_1: "(Determinant.det Q dvd 1)"
    using invertible_iff_is_unit_JNF[OF Q] inv_Q by auto
  moreover have det_Q_eq: "Determinant.det Q = ?s*?a1 + ?t*?b1" unfolding det_2[OF Q] by simp
  ultimately have "?s*?a1 + ?t*?b1 dvd 1" by auto
  from this obtain u where u_eq: "?s*?a1 + ?t*?b1 = u" and u: "u dvd 1" by auto
  hence eq1: "?s*?a1*a + ?t*?b1*a = u*a"
    by (metis ring_class.ring_distribs(2))
  hence "?s*?a1*a + ?t*?a1*b = u*a"
    by (metis (no_types, lifting) ab1_ba1 mult.assoc mult.commute)
  hence a1d_ua:"?a1*?d=u*a"
    by (smt Groups.mult_ac(2) distrib_left more_arith_simps(11) sa_tb_d)
  hence b1d_ub: "?b1*?d=u*b"
    by (smt Groups.mult_ac(2) Groups.mult_ac(3) ab1_ba1 distrib_right sa_tb_d u_eq)
  obtain inv_u where inv_u: "inv_u * u = 1" using u unfolding dvd_def
    by (metis mult.commute)
  hence inv_u_dvd_1: "inv_u dvd 1" unfolding dvd_def by auto
  have cond1: "(inv_u*?b1)*?d = b" using b1d_ub inv_u
    by (metis (no_types, lifting) Groups.mult_ac(3) more_arith_simps(11) more_arith_simps(6))
  have cond2: "(inv_u*?a1)*?d = a" using a1d_ua inv_u
    by (metis (no_types, lifting) Groups.mult_ac(3) more_arith_simps(11) more_arith_simps(6))
  have "ideal_generated {inv_u*?a1, inv_u*?b1} = ideal_generated {?a1,?b1}"
    by (rule ideal_generated_mult_unit2[OF inv_u_dvd_1])    
  also have "... = UNIV" using ideal_generated_pair_UNIV[OF u_eq u] by simp
  finally have cond3: "ideal_generated {inv_u*?a1, inv_u*?b1} = ideal_generated {1}" by auto
  show "a1 b1 d. a = a1 * d  b = b1 * d  ideal_generated {a1, b1} = ideal_generated {1}"
    by (rule exI[of _ "inv_u*?a1"], rule exI[of _ "inv_u*?b1"], rule exI[of _ ?d],
        insert cond1 cond2 cond3, auto)
qed
  

theorem theorem3:
  shows "(A::'a mat. admits_triangular_reduction A)
  = (a b::'a.  a1 b1 d. a = a1*d  b = b1*d  ideal_generated {a1,b1} = ideal_generated {1})"
  using theorem3_part1 theorem3_part2 by auto

end



context comm_ring_1
begin


lemma lemma4_prev:
  assumes a: "a = a1*d" and b: "b = b1*d"
  and i: "ideal_generated {a1,b1} = ideal_generated {1}"
shows "ideal_generated {a,b} = ideal_generated {d}"
proof -
 have 1: "k. p * (a1 * d) + q * (b1 * d) = k * d" for p q
    by (metis (full_types) local.distrib_right local.mult.semigroup_axioms semigroup.assoc)  
  have "ideal_generated {a,b}  ideal_generated {d}"
  proof -
    have "ideal_generated {a,b} = {p*a+q*b | p q. True}" using ideal_generated_pair by auto
    also have "... = {p*(a1*d)+q*(b1*d) | p q. True}" using a b by auto
    also have "...  {k*d|k. True}" using 1 by auto
    finally show ?thesis
      by (simp add: a b local.dvd_ideal_generated_singleton' local.ideal_generated_subset2)
  qed
  moreover have "ideal_generated{d}  ideal_generated {a,b}" 
  proof (rule ideal_generated_singleton_subset)
    obtain p q where "p*a1+q*b1 = 1" using ideal_generated_pair_exists_UNIV i by auto
    hence "d = p * (a1 * d) + q * (b1 * d)"
      by (metis local.mult_ac(3) local.ring_distribs(1) local.semiring_normalization_rules(12))
    also have "...   {p*(a1*d)+q*(b1*d) | p q. True}" by auto
    also have "... = ideal_generated {a,b}" unfolding ideal_generated_pair a b by auto
    finally show "d  ideal_generated {a,b}" by simp
  qed (simp)
  ultimately show ?thesis by simp
qed


lemma lemma4:
  assumes a: "a = a1*d" and b: "b = b1*d"
    and i: "ideal_generated {a1,b1} = ideal_generated {1}"
    and i2: "ideal_generated {a,b} = ideal_generated {d'}"
  shows "a1' b1'. a = a1' * d'  b = b1' * d' 
     ideal_generated {a1',b1'} = ideal_generated {1}"
proof -
  have i3: "ideal_generated {a,b} = ideal_generated {d}" using lemma4_prev assms by auto
  have d_dvd_d': "d dvd d'"
    by (metis a b i2 dvd_ideal_generated_singleton dvd_ideal_generated_singleton' 
        dvd_triv_right ideal_generated_subset2)
  have d'_dvd_d: "d' dvd d" 
    using i3 i2 local.dvd_ideal_generated_singleton by auto
  obtain k and l where d: "d = k*d'" and d': "d' = l*d"
    using d_dvd_d' d'_dvd_d mult_ac unfolding dvd_def by auto
  obtain s t where sa1_tb1: "s*a1 + t*b1 = 1"
    using i ideal_generated_pair_exists_UNIV[of a1 b1] by auto
  let ?a1' = "k * l * t - t + a1 * k"
  let ?b1' = "s - k * l * s + b1 * k"
  have 1: "?a1'*d'=a"
    by (metis a d d' add_ac(2) add_diff_cancel add_diff_eq mult_ac(2) ring_distribs(1,4) 
        semiring_normalization_rules(18))
  have 2: "?b1'*d' = b"
    by (metis (no_types, hide_lams) b d d' add_ac(2) add_diff_cancel add_diff_eq mult_ac(2) mult_ac(3) 
        ring_distribs(2,4) semiring_normalization_rules(18)) 
  have "(s*l-b1)*?a1' + (t*l+a1)*?b1' = 1"
  proof -
    have aux_rw1: "s * l * k * l * t = t * l * k * l * s" and aux_rw2: "s * l * t=t * l * s" 
      and aux_rw3: "b1 * a1 * k=a1 * b1 * k" and aux_rw4: "t * l * b1 * k=b1 * k * l * t"
      and aux_rw5: "s * l * a1 * k=a1 * k * l * s"
      using mult.commute mult.assoc by auto
    note aux_rw = aux_rw1 aux_rw2 aux_rw3 aux_rw4 aux_rw5
    have "(s*l-b1)*?a1' + (t*l+a1)*?b1' = s*l*?a1' - b1*?a1' + t*l*?b1'+a1*?b1'"
      using local.add_ac(1) local.left_diff_distrib' local.ring_distribs(2) by auto
    also have "... = s * l * k * l*t - s * l * t + s * l * a1 * k-b1 * k * l * t + b1 * t-b1 * a1 * k
      + t * l * s-t * l * k * l * s + t * l * b1 * k + a1 * s - a1 * k * l * s + a1 * b1 * k"
      by (smt abel_semigroup.commute add.abel_semigroup_axioms diff_add_eq diff_diff_eq2
          mult.semigroup_axioms ring_distribs(4) semiring_normalization_rules(34) semigroup.assoc)
    also have "... = a1 * s + b1 * t" unfolding aux_rw
      by (smt add_ac(2) add_ac(3) add_minus_cancel ring_distribs(4) ring_normalization_rules(2))
    also have "... = 1" using sa1_tb1 mult.commute by auto
    finally show ?thesis by simp
  qed
  hence "ideal_generated {?a1',?b1'} = ideal_generated {1}"
    using ideal_generated_pair_exists_UNIV[of ?a1' ?b1'] by auto
  thus ?thesis using 1 2 by auto
qed


(*In the article, this is a corollary. But here, this needs more work.*)
lemma corollary5:
  assumes T: "a b. a1 b1 d. a = a1 * d  b = b1 * d 
         ideal_generated {a1, b1} = ideal_generated {1::'a}"
 and i2: "ideal_generated {a,b,c} = ideal_generated {d}"
  shows " a1 b1 c1. a = a1 * d  b = b1 * d  c = c1 * d 
   ideal_generated {a1,b1,c1} = ideal_generated {1}"
proof -
  have da: "d dvd a" using ideal_generated_singleton_dvd[OF i2] by auto
  have db: "d dvd b" using ideal_generated_singleton_dvd[OF i2] by auto
  have dc: "d dvd c" using ideal_generated_singleton_dvd[OF i2] by auto
  from this obtain c1' where c: "c = c1' * d" using dvd_def mult_ac(2) by auto
  obtain a1 b1 d' where a: "a = a1 * d'" and b: "b = b1 * d' "
    and i: "ideal_generated {a1, b1} = ideal_generated {1::'a}" using T by blast
  have i_ab_d': "ideal_generated {a, b} = ideal_generated {d'}"
    by (simp add: a b i lemma4_prev)
  have i2: "ideal_generated {d', c} = ideal_generated {d}"
    by (rule ideal_generated_triple_pair_rewrite[OF i2 i_ab_d'])  
  obtain u v dp  where d'1: "d' = u * dp" and d'2: "c = v * dp" 
    and xy: "ideal_generated{u,v}=ideal_generated{1}" using T by blast
  have "a1' b1'. d' = a1' * d  c = b1' * d  ideal_generated {a1', b1'} = ideal_generated {1}"
    by (rule lemma4[OF d'1 d'2 xy i2])
  from this obtain a1' c1 where d'_a1: "d' = a1' * d" and c: "c = c1 * d" 
    and i3: "ideal_generated {a1', c1} = ideal_generated {1}" by blast
  have r1: "a = a1 * a1' * d" by (simp add: d'_a1 a local.semiring_normalization_rules(18))
  have r2: "b = b1 * a1' * d" by (simp add: d'_a1 b local.semiring_normalization_rules(18))
  have i4: "ideal_generated {a1 * a1',b1 * a1', c1} = ideal_generated {1}"
  proof -
    obtain p q where 1: "p * a1' + q * c1 = 1" 
      using i3 unfolding ideal_generated_pair_exists_UNIV by auto
    obtain x y where 2: "x*a1 + y*b1 = p" using ideal_generated_UNIV_obtain_pair[OF i] by blast
    have "1 = (x*a1 + y*b1) * a1' + q * c1" using 1 2 by auto
    also have "... = x*a1*a1' + y*b1*a1' + q * c1" by (simp add: local.ring_distribs(2))
    finally have "1 = x*a1*a1' + y*b1*a1' + q * c1" .
    hence "1  ideal_generated {a1 * a1', b1 * a1', c1}" 
      using ideal_explicit2[of "{a1 * a1', b1 * a1', c1}"] sum_three_elements'
      by (simp add: mult_assoc)
    hence "ideal_generated {1}  ideal_generated {a1 * a1',b1 * a1', c1}"
      by (rule ideal_generated_singleton_subset, auto)   
    thus ?thesis by auto
  qed
  show ?thesis using r1 r2 i4 c by auto
qed


end

context
  assumes "SORT_CONSTRAINT('a::comm_ring_1)"
begin

lemma OFCLASS_elementary_divisor_ring_imp_class:
  assumes "OFCLASS('a::comm_ring_1, elementary_divisor_ring_class)"
  shows " class.elementary_divisor_ring TYPE('a)" 
  by (rule conjunctionD2[OF assms[unfolded elementary_divisor_ring_class_def]])


(*ELEMENTARY DIVISOR RING ⟹ HERMITE*)
corollary Elementary_divisor_ring_imp_Hermite_ring:
  assumes "OFCLASS('a::comm_ring_1, elementary_divisor_ring_class) "
  shows "OFCLASS('a::comm_ring_1, Hermite_ring_class)"
proof
  have "A::'a mat. admits_diagonal_reduction A" 
    using OFCLASS_elementary_divisor_ring_imp_class[OF assms] 
    unfolding class.elementary_divisor_ring_def by auto
  thus "A::'a mat. admits_triangular_reduction A" 
    using admits_diagonal_imp_admits_triangular by auto
qed

(*ELEMENTARY DIVISOR RING ⟹ BEZOUT*)
corollary Elementary_divisor_ring_imp_Bezout_ring:
  assumes "OFCLASS('a::comm_ring_1, elementary_divisor_ring_class) "
  shows "OFCLASS('a::comm_ring_1, bezout_ring_class)"
  by (rule Hermite_ring_imp_Bezout_ring, rule Elementary_divisor_ring_imp_Hermite_ring[OF assms])

subsection ‹Characterization of Elementary divisor rings›

lemma necessity_D': 
  assumes edr: "((A::'a mat). admits_diagonal_reduction A)"
  shows "a b c::'a. ideal_generated {a,b,c} = ideal_generated{1} 
   (p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})"
proof ((rule allI)+, rule impI)
  fix a b c::'a 
  assume i: "ideal_generated {a,b,c} = ideal_generated{1}"  
  define A where "A = Matrix.mat 2 2 (λ(i,j). if i = 0  j = 0 then a else
                                    if  i = 0  j = 1 then b else
                                    if  i = 1  j = 0 then 0 else c)"
  have A: "A  carrier_mat 2 2" unfolding A_def by auto
  obtain P Q where P: "P  carrier_mat (dim_row A) (dim_row A)"
        and Q: "Q  carrier_mat (dim_col A) (dim_col A)" 
        and inv_P: "invertible_mat P" and inv_Q: "invertible_mat Q" 
        and SNF_PAQ: "Smith_normal_form_mat (P * A * Q)"
    using edr unfolding admits_diagonal_reduction_def by blast
  have [simp]: "dim_row P = 2" and [simp]: "dim_col P = 2 " and [simp]: "dim_row Q = 2" 
    and [simp]: "dim_col Q = 2" and [simp]: "dim_col A = 2" and [simp]: "dim_row A = 2" 
    using A P Q by auto
  define u where "u = (P*A*Q) $$ (0,0)"  
  define p where "p = P $$ (0,0)"
  define q where "q = P $$ (0,1)"
  define x where "x = Q $$ (0,0)"
  define y where "y = Q $$ (1,0)"
  have eq: "p*a*x + p*b*y + q*c*y = u"
  proof -   
    have rw1: "(ia = 0..<2. P $$ (0, ia) * A $$ (ia, x)) * Q $$ (x, 0) 
    = (ia{0, 1}. P $$ (0, ia) * A $$ (ia, x)) * Q $$ (x, 0)" 
      for x by (unfold sum_distrib_right, rule sum.cong, auto) 
    have "u = (i = 0..<2. (ia = 0..<2. P $$ (0, ia) * A $$ (ia, i)) * Q $$ (i, 0))"
      unfolding u_def p_def q_def x_def y_def
      unfolding times_mat_def scalar_prod_def by auto
    also have "... = (i {0,1}. (ia  {0,1}. P $$ (0, ia) * A $$ (ia, i)) * Q $$ (i, 0))"
      by (rule sum.cong[OF _ rw1], auto)    
    also have "... = p*a*x + p*b*y+q*c*y"
      unfolding u_def p_def q_def x_def y_def A_def 
      using ring_class.ring_distribs(2) by auto
    finally show ?thesis ..
  qed  
  have u_dvd_1: "u dvd 1"
  (*
  The article deduces this fact since u divides all the elements of the matrix A. Here, this is 
  already proved using GCD and minors, but it requires the semiring_GCD class.
  At the end, I proved this fact by means of matrix multiplications once the inverse matrices of P
  and Q are obtained.
  *)
  proof (rule ideal_generated_dvd2[OF i])
    define D where "D = (P*A*Q)"
    obtain P' where  P'[simp]: "P'  carrier_mat 2 2" and inv_P: "inverts_mat P' P" 
      using inv_P obtain_inverse_matrix[OF P inv_P]
      by (metis ‹dim_row A = 2)      
    obtain Q' where [simp]: "Q'  carrier_mat 2 2" and inv_Q: "inverts_mat Q Q'" 
      using inv_Q obtain_inverse_matrix[OF Q inv_Q]
      by (metis ‹dim_col A = 2)
    have D[simp]: "D  carrier_mat 2 2" unfolding D_def by auto
    have e: "P' * D * Q' = A" unfolding D_def by (rule inv_P'PAQQ'[OF _ _ inv_P inv_Q], auto)
    have [simp]: "(P' * D)  carrier_mat 2 2" using D P' mult_carrier_mat by blast
    have D_01: "D $$ (0, 1) = 0" 
      using D_def SNF_PAQ unfolding Smith_normal_form_mat_def isDiagonal_mat_def by force
    have D_10: "D $$ (1, 0) = 0"
      using D_def SNF_PAQ unfolding Smith_normal_form_mat_def isDiagonal_mat_def by force
    have "D $$ (0,0) dvd D $$ (1, 1)" 
      using D_def SNF_PAQ unfolding Smith_normal_form_mat_def by auto
    from this obtain k where D11: "D $$ (1, 1) = D $$ (0,0) * k" unfolding dvd_def by blast
    have P'D_00: "(P' * D) $$ (0, 0) = P' $$ (0, 0) * D $$ (0, 0)" 
      using mat_mult2_00[of P' D] D_10 by auto 
    have P'D_01: "(P' * D) $$ (0, 1) =  P' $$ (0, 1) * D $$ (1, 1)" 
      using mat_mult2_01[of P' D] D_01 by auto
    have P'D_10: "(P' * D) $$ (1, 0) = P' $$ (1, 0) * D $$ (0, 0)" 
      using mat_mult2_10[of P' D] D_10 by auto
    have P'D_11: "(P' * D) $$ (1, 1) = P' $$ (1, 1) * D $$ (1, 1)" 
      using mat_mult2_11[of P' D] D_01 by auto
    have "a = (P' * D * Q') $$ (0,0)" using e A_def by auto
    also have "... = (P' * D) $$ (0, 0) * Q' $$ (0, 0) + (P' * D) $$ (0, 1) * Q' $$ (1, 0)" 
      by (rule mat_mult2_00, auto)
    also have "... = P' $$ (0, 0) * D $$ (0, 0) * Q' $$ (0, 0) 
      + P' $$ (0, 1) * (D $$ (0, 0) * k) * Q' $$ (1, 0)" unfolding P'D_00 P'D_01 D11 ..
    also have "... = D $$ (0, 0) * (P' $$ (0, 0) * Q' $$ (0, 0) 
      + P' $$ (0, 1) * k * Q' $$ (1, 0))" by (simp add: distrib_left)
    finally have u_dvd_a: "u dvd a" unfolding u_def D_def dvd_def by auto
    have "b = (P' * D * Q') $$ (0,1)" using e A_def by auto
    also have "... = (P' * D) $$ (0, 0) * Q' $$ (0, 1) + (P' * D) $$ (0, 1) * Q' $$ (1, 1)" 
      by (rule mat_mult2_01, auto)
    also have "... =  P' $$ (0, 0) * D $$ (0, 0) * Q' $$ (0, 1) +
       P' $$ (0, 1) * (D $$ (0, 0) * k) * Q' $$ (1, 1)" 
      unfolding P'D_00 P'D_01 D11 ..
    also have "... = D $$ (0, 0) * (P' $$ (0, 0) * Q' $$ (0, 1) +
       P' $$ (0, 1) * k * Q' $$ (1, 1))"  by (simp add: distrib_left)
    finally have u_dvd_b: "u dvd b" unfolding u_def D_def dvd_def by auto
    have "c = (P' * D * Q') $$ (1,1)" using e A_def by auto
    also have "... = (P' * D) $$ (1, 0) * Q' $$ (0, 1) + (P' * D) $$ (1, 1) * Q' $$ (1, 1)" 
      by (rule mat_mult2_11, auto)
    also have "... = P' $$ (1, 0) * D $$ (0, 0) * Q' $$ (0, 1) 
        + P' $$ (1, 1) * (D $$ (0, 0) * k) * Q' $$ (1, 1)" unfolding P'D_11 P'D_10 D11 ..
    also have "... = D $$ (0, 0) * (P' $$ (1, 0) * Q' $$ (0, 1) 
        + P' $$ (1, 1) * k * Q' $$ (1, 1))" by (simp add: distrib_left)
    finally have u_dvd_c: "u dvd c" unfolding u_def D_def dvd_def by auto
    show "x{a,b,c}. u dvd x" using u_dvd_a u_dvd_b u_dvd_c by auto
  qed (simp)
  have "ideal_generated {p*a,p*b+q*c} = ideal_generated {1}"
    by (metis (no_types, lifting) eq add.assoc ideal_generated_1 ideal_generated_pair_UNIV 
        mult.commute semiring_normalization_rules(34) u_dvd_1)
  from this show "p q. ideal_generated {p * a, p * b + q * c} = ideal_generated {1}"
    by auto
qed

lemma necessity:
  assumes "((A::'a mat). admits_diagonal_reduction A)"
  shows "((A::'a mat). admits_triangular_reduction A)"
 and "a b c::'a. ideal_generated{a,b,c} = ideal_generated{1} 
   (p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})"
  using necessity_D' admits_diagonal_imp_admits_triangular assms
  by blast+

text ‹In the article, the authors change the notation and assume $(a,b,c) = (1)$. However,
we have to provide here the complete prove. To to this, I obtained a $D$ matrix such that
$A' = A*D$ and $D$ is a diagonal matrix with $d$ in the diagonal. Proving that $D$ is 
left and right commutative, I can follow the reasoning in the article›

lemma sufficiency:
  assumes hermite_ring: "((A::'a mat). admits_triangular_reduction A)"
    and D': "a b c::'a. ideal_generated{a,b,c} = ideal_generated{1} 
     (p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})"
  shows "((A::'a mat). admits_diagonal_reduction A)"
proof -
  have admits_1x2: "(A::'a mat)  carrier_mat 1 2. admits_diagonal_reduction A"
    using hermite_ring triangular_eq_diagonal_1x2 by blast
  have admits_2x2: "(A::'a mat)  carrier_mat 2 2. admits_diagonal_reduction A"
  proof 
    fix B::"'a mat" assume B: "B  carrier_mat 2 2"
    obtain U where BU: "lower_triangular (B*U)" and inv_U: "invertible_mat U"
      and U: "U  carrier_mat 2 2" 
      using hermite_ring unfolding admits_triangular_reduction_def using B by fastforce
    define A where "A = B*U"
    define a where "a = A $$ (0,0)"
    define b where "b = A $$ (1,0)"
    define c where "c = A $$ (1,1)"
    have A: "A  carrier_mat 2 2" using U B A_def by auto
    have A_01: "A$$(0,1) = 0" using BU U B unfolding lower_triangular_def A_def by auto    
    obtain d::'a where i: "ideal_generated {a,b,c} = ideal_generated {d}"      
      (*This fact is true since all the finitely generated ideals are principal ideals 
        in a Hermite ring*)  
    proof -
      have "OFCLASS('a, bezout_ring_class)" by (rule Hermite_ring_imp_Bezout_ring,
            insert OFCLASS_Hermite_ring_def[where ?'a='a] hermite_ring, auto)                
      hence "class.bezout_ring (*) (1::'a) (+) 0 (-) uminus" 
        using OFCLASS_bezout_ring_imp_class_bezout_ring[where ?'a = 'a] by auto
      hence "(I::'a::comm_ring_1 set. finitely_generated_ideal I  principal_ideal I)"
        using bezout_ring_iff_fin_gen_principal_ideal2 by auto 
      moreover have "finitely_generated_ideal (ideal_generated {a,b,c})" 
        unfolding finitely_generated_ideal_def
        using ideal_ideal_generated by force
      ultimately have "principal_ideal (ideal_generated {a,b,c})" by auto
      thus ?thesis using that unfolding principal_ideal_def by auto
    qed
    have d_dvd_a: "d dvd a" and d_dvd_b: "d dvd b" and d_dvd_c: "d dvd c"
      using i ideal_generated_singleton_dvd by blast+    
    obtain a1 b1 c1 where a1: "a = a1 * d" and b1: "b = b1 * d" and c1: "c = c1 * d"
      and i2: "ideal_generated {a1,b1,c1} = ideal_generated {1}"
    proof -
      have T: "a b. a1 b1 d. a = a1 * d  b = b1 * d 
         ideal_generated {a1, b1} = ideal_generated {1::'a}"
        by (rule theorem3_part2[OF hermite_ring]) (*Hermite ring is equivalent to the property T*)
      from this obtain a1' b1' d' where 1: "a = a1' * d'" and 2: "b = b1' * d'"
        and 3: "ideal_generated {a1', b1'} = ideal_generated {1::'a}" by blast
      have "a1 b1 c1. a = a1 * d  b = b1 * d  c = c1 * d 
         ideal_generated {a1, b1, c1} = ideal_generated {1}"
        by (rule corollary5[OF T i])      
      from this show ?thesis using that by auto
    qed
     
    define D where "D = d m (1m 2)"
    define A' where "A' = Matrix.mat 2 2 (λ(i,j). if i = 0  j = 0 then a1 else
                                    if  i = 1  j = 0 then b1 else
                                    if  i = 0  j = 1 then 0 else c1)"
    have D: "D  carrier_mat 2 2" and A': "A' carrier_mat 2 2" unfolding A'_def D_def by auto
    have A_A'D: "A = A' * D" 
      by (rule eq_matI, insert D A' A a1 b1 c1 A_01 sum_two_rw a_def b_def c_def,
      unfold scalar_prod_def Matrix.row_def col_def  D_def A'_def, 
      auto simp add: sum_two_rw less_Suc_eq numerals(2))    
    have "1 ideal_generated{a1,b1,c1}" using i2  by (simp add: ideal_generated_in) 
    from this obtain f where d: "(i{a1,b1,c1}. f i * i) = 1"
      using ideal_explicit2[of "{a1,b1,c1}"] by auto
    from this obtain x y z where "x*a1+y*b1+z*c1 = 1" 
      using sum_three_elements[of _ a1 b1 c1] by metis
    hence xa1_yb1_zc1_dvd_1: "x * a1 + y * b1 + z * c1 dvd 1" by auto    
    obtain p q where i3: "ideal_generated {p*a1,p*b1+q*c1} = ideal_generated {1}"
      using D' i2 by blast
    have "ideal_generated {p,q} = UNIV"
    proof -
      obtain X Y where e: "X*p*a1 + Y*(p*b1+q*c1) = 1"
        by (metis i3 ideal_generated_1 ideal_generated_pair_exists_UNIV mult.assoc)
      have "X*p*a1 + Y*(p*b1+q*c1) = X*p*a1 + Y*p*b1+Y*q*c1"
        by (simp add: add.assoc mult.assoc semiring_normalization_rules(34))
      also have "... = (X*a1+Y*b1) * p + (Y * c1) * q"
        by (simp add: mult.commute ring_class.ring_distribs)
      finally have "(X*a1+Y*b1) * p + Y * c1 * q = 1" using e by simp
      from this show ?thesis by (rule ideal_generated_pair_UNIV, simp)
    qed
    from this obtain u v where pu_qv_1: "p*u - q * v = 1"
      by (metis Groups.mult_ac(2) diff_minus_eq_add ideal_generated_1 
          ideal_generated_pair_exists_UNIV mult_minus_left)
    let ?P = "Matrix.mat 2 2 (λ(i,j). if i = 0  j = 0 then p else
                                    if  i = 1  j = 0 then q else
                                    if  i = 0  j = 1 then v else u)"
    have P: "?P  carrier_mat 2 2" by auto
    have "Determinant.det ?P = 1" using pu_qv_1 unfolding det_2[OF P] by (simp add: mult.commute)
    hence inv_P: "invertible_mat ?P"
      by (metis (no_types, lifting) P dvd_refl invertible_iff_is_unit_JNF)
    define S1 where "S1 = A'*?P"
    have S1: "S1  carrier_mat 2 2" using A' P S1_def mult_carrier_mat by blast
    have S1_00: "S1 $$(0,0) = p*a1" and S1_01: "S1 $$(1,0) = p*b1+q*c1" 
      unfolding S1_def times_mat_def scalar_prod_def using A' P BU U B 
      unfolding A'_def upper_triangular_def      
      by (auto, unfold sum_two_rw, auto simp add: A'_def a_def b_def c_def) 
    obtain q00 and q01 where q00_q01: "p*a1*q00 + (p*b1+q*c1)*q01 = 1" using i3
      by (metis ideal_generated_1 ideal_generated_pair_exists_pq1 mult.commute)
    define q10 where "q10 = - (p*b1+q*c1)"
    define q11 where "q11 = p*a1"
    have q10_q11: "p*a1*q10 + (p*b1+q*c1)*q11 = 0" unfolding q10_def q11_def
      by (auto simp add: Rings.ring_distribs(1) Rings.ring_distribs(4) semiring_normalization_rules(7))  
    let ?Q = "Matrix.mat 2 2 (λ(i,j). if i = 0  j = 0 then q00 else
                                    if  i = 1  j = 0 then q10 else
                                    if  i = 0  j = 1 then q01 else q11)"
    have Q: "?Q  carrier_mat 2 2" by auto
    have "Determinant.det ?Q = 1" using q00_q01 unfolding det_2[OF Q] unfolding q10_def q11_def
      by (auto, metis (no_types, lifting) add_uminus_conv_diff diff_minus_eq_add more_arith_simps(7)
          more_arith_simps(9) mult.commute)
    hence inv_Q: "invertible_mat ?Q" by (smt Q dvd_refl invertible_iff_is_unit_JNF)
    define S2 where "S2 = ?Q * S1 "
    have S2: "S2  carrier_mat 2 2" using A' P S2_def S1 Q mult_carrier_mat by blast
    have S2_00: "S2 $$ (0,0) = 1" unfolding mat_mult2_00[OF Q S1 S2_def] using q00_q01 
      unfolding S1_00 S1_01 by (simp add: mult.commute)
    have S2_10: "S2 $$ (1,0) = 0" unfolding mat_mult2_10[OF Q S1 S2_def] 
      using q10_q11 unfolding S1_00 S1_01 by (simp add: Groups.mult_ac(2)) 
        (*Now we have a zero in the upper-right position. 
          We want to get also a zero in the lower-left position.*)
    let ?P1 ="(addrow_mat 2 (- (S2$$(0,1))) 0 1)"
    have P1: "?P1  carrier_mat 2 2" by auto
    have inv_P1: "invertible_mat ?P1"
      by (metis addrow_mat_carrier arithmetic_simps(78) det_addrow_mat dvd_def 
          invertible_iff_is_unit_JNF numeral_One zero_neq_numeral)
    define S3 where "S3 = S2 * ?P1"
    have P1_P_A': " A' *?P *?P1  carrier_mat 2 2" using P1 P A' mult_carrier_mat by auto
    have S3: "S3  carrier_mat 2 2" using P1 S2 S3_def mult_carrier_mat by blast
    have S3_00: "S3 $$ (0,0) = 1" using S2_00 unfolding mat_mult2_00[OF S2 P1  S3_def] by auto     
    moreover have S3_01: "S3 $$ (0,1) = 0" using S2_00 unfolding mat_mult2_01[OF S2 P1 S3_def] by auto
    moreover have S3_10: "S3 $$ (1,0) = 0" using S2_10 unfolding mat_mult2_10[OF S2 P1 S3_def] by auto
    ultimately have SNF_S3: "Smith_normal_form_mat S3"
      using S3 unfolding Smith_normal_form_mat_def isDiagonal_mat_def
      using less_2_cases by auto 
    hence SNF_S3_D: "Smith_normal_form_mat (S3*D)"
      using D_def S3 SNF_preserved_multiples_identity by blast
    have "S3 * D = ?Q * A' * ?P * ?P1 * D" using S1_def S2_def S3_def
      by (smt A' P Q S1 addrow_mat_carrier assoc_mult_mat)
    also have "... = ?Q * A' * ?P * (?P1 * D)"
      by (meson A' D addrow_mat_carrier assoc_mult_mat mat_carrier mult_carrier_mat)
    also have "... = ?Q * A' * ?P * (D * ?P1)" 
      using commute_multiples_identity[OF P1] unfolding D_def by auto
    also have "... = ?Q * A' * (?P * (D * ?P1))"
      by (smt A' D assoc_mult_mat carrier_matD(1) carrier_matD(2) mat_carrier times_mat_def)
    also have "... = ?Q * A' * (D * (?P * ?P1))"
      by (smt D D_def P P1 assoc_mult_mat commute_multiples_identity)
    also have "... = ?Q * (A' * D) * (?P * ?P1)"
      by (smt A' D assoc_mult_mat carrier_matD(1) carrier_matD(2) mat_carrier times_mat_def)
    also have "... = ?Q * A * (?P * ?P1)" unfolding A_A'D by auto     
    also have "... = ?Q * B * (U * (?P * ?P1))" unfolding A_def 
      by (smt B U assoc_mult_mat carrier_matD(1) carrier_matD(2) mat_carrier times_mat_def)
   finally have S3_D_rw: "S3 * D = ?Q * B * (U * (?P * ?P1))" .
    show "admits_diagonal_reduction B" 
    proof (rule admits_diagonal_reduction_intro[OF _ _ inv_Q])    
      show "(U* (?P * ?P1))  carrier_mat (dim_col B) (dim_col B)" using B U by auto
      show "?Q  carrier_mat (dim_row B) (dim_row B)" using Q B by auto
      show "invertible_mat (U * (?P * ?P1))"
        by (metis (no_types, lifting) P1 U carrier_matD(1) carrier_matD(2) inv_P inv_P1 inv_U 
            invertible_mult_JNF mat_carrier times_mat_def)
      show "Smith_normal_form_mat (?Q * B *(U* (?P * ?P1)))" using SNF_S3_D S3_D_rw by simp
    qed    
  qed
  obtain Smith_1x2 where Smith_1x2: "(A::'a mat)carrier_mat 1 2. is_SNF A (Smith_1x2 A)"
    using admits_diagonal_reduction_imp_exists_algorithm_is_SNF_all[OF admits_1x2] by auto
  from this obtain Smith_1x2' 
    where Smith_1x2': "(A::'a mat)carrier_mat 1 2. is_SNF A (1m 1, Smith_1x2' A)"
    using Smith_1xn_two_matrices_all[OF Smith_1x2] by auto
  obtain Smith_2x2 where Smith_2x2: "(A::'a mat)carrier_mat 2 2. is_SNF A (Smith_2x2 A)"
    using admits_diagonal_reduction_imp_exists_algorithm_is_SNF_all[OF admits_2x2] by auto  
  have d: "is_div_op (λa b. (SOME k. k * b = a))" using div_op_SOME by auto
  interpret Smith_Impl Smith_1x2' Smith_2x2 "(λa b. (SOME k. k * b = a))" 
    using Smith_1x2' Smith_2x2 d by (unfold_locales, auto)
  show ?thesis using is_SNF_Smith_mxn
    by (meson admits_diagonal_reduction_eq_exists_algorithm_is_SNF carrier_mat_triv)
qed

subsection ‹Final theorem›

(* Characterization of elementary divisor rings (theorem 6)*)

theorem edr_characterization:
  "((A::'a mat). admits_diagonal_reduction A) = (((A::'a mat). admits_triangular_reduction A) 
   (a b c::'a. ideal_generated{a,b,c} = ideal_generated{1} 
                       (p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})))"
  using necessity sufficiency by blast


corollary OFCLASS_edr_characterization:
"OFCLASS('a, elementary_divisor_ring_class)  (OFCLASS('a, Hermite_ring_class) 
  &&& (a b c::'a. ideal_generated{a,b,c} = ideal_generated{1} 
     (p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})))" (is "?lhs  ?rhs")
proof 
  assume 1: "OFCLASS('a, elementary_divisor_ring_class)"
  hence admits_diagonal: "A::'a mat. admits_diagonal_reduction A"
    using conjunctionD2[OF 1[unfolded elementary_divisor_ring_class_def]] 
    unfolding class.elementary_divisor_ring_def by auto
  have "A::'a mat. admits_triangular_reduction A" by (simp add: admits_diagonal necessity(1))
  hence OFCLASS_Hermite: "OFCLASS('a, Hermite_ring_class)" by (intro_classes, simp)
  moreover have "a b c::'a. ideal_generated {a, b, c} = ideal_generated {1} 
                   (p q. ideal_generated {p * a, p * b + q * c} = ideal_generated {1})"
    using admits_diagonal necessity(2) by blast
  ultimately show "OFCLASS('a, Hermite_ring_class) &&& 
  a b c::'a. ideal_generated {a, b, c} = ideal_generated {1} 
   (p q. ideal_generated {p * a, p * b + q * c} = ideal_generated {1})"
   by auto
next
  assume 1: "OFCLASS('a, Hermite_ring_class) &&&
      a b c::'a. ideal_generated {a, b, c} = ideal_generated {1} 
        (p q. ideal_generated {p * a, p * b + q * c} = ideal_generated {1})"
  have H: "OFCLASS('a, Hermite_ring_class)"
      and 2: "a b c::'a. ideal_generated {a, b, c} = ideal_generated {1} 
        (p q. ideal_generated {p * a, p * b + q * c} = ideal_generated {1})"
    using conjunctionD1[OF 1] conjunctionD2[OF 1] by auto
  have "A::'a mat. admits_triangular_reduction A" 
    using H unfolding OFCLASS_Hermite_ring_def by auto
  hence a: "A::'a mat. admits_diagonal_reduction A" using 2 sufficiency by blast
  show "OFCLASS('a, elementary_divisor_ring_class)" by (intro_classes, simp add: a)
qed

corollary edr_characterization_class:
"class.elementary_divisor_ring TYPE('a) 
  = (class.Hermite_ring TYPE('a) 
   (a b c::'a. ideal_generated{a,b,c} = ideal_generated{1} 
 (p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1})))" (is "?lhs = (?H  ?D')")
proof 
  assume 1: ?lhs
  hence admits_diagonal: "A::'a mat. admits_diagonal_reduction A" 
    unfolding class.elementary_divisor_ring_def .
  have admits_triangular: "A::'a mat. admits_triangular_reduction A"
    using 1 necessity(1) unfolding class.elementary_divisor_ring_def by blast 
  hence "?H" unfolding class.Hermite_ring_def by auto 
  moreover have "?D'" using admits_diagonal necessity(2) by blast
  ultimately show "(?H  ?D')" by simp
next
  assume HD': "(?H  ?D')"
  hence admits_triangular: "A::'a mat. admits_triangular_reduction A"
    unfolding class.Hermite_ring_def by auto
  hence admits_diagonal: "A::'a mat. admits_diagonal_reduction A" 
    using edr_characterization HD' by auto      
  thus ?lhs unfolding class.elementary_divisor_ring_def by auto
qed


corollary edr_iff_T_D':
  shows "class.elementary_divisor_ring TYPE('a) = (
    (a b::'a.  a1 b1 d. a = a1*d  b = b1*d  ideal_generated {a1,b1} = ideal_generated {1})
   (a b c::'a. ideal_generated{a,b,c} = ideal_generated{1} 
       (p q. ideal_generated {p*a,p*b+q*c} = ideal_generated {1}))
  )" (is "?lhs = (?T  ?D')")
proof
  assume 1: ?lhs
  hence "A::'a mat. admits_triangular_reduction A"
    unfolding class.elementary_divisor_ring_def using necessity(1) by blast 
  hence "?T" using theorem3_part2 by simp
  moreover have "?D'"  using 1 unfolding edr_characterization_class by auto
  ultimately show "(?T  ?D')" by simp
next
  assume TD': "(?T  ?D')"
  hence "class.Hermite_ring TYPE('a)" 
    unfolding class.Hermite_ring_def using theorem3_part1 TD' by auto
  thus ?lhs using edr_characterization_class TD' by auto
qed

end
end

Theory SNF_Algorithm_Euclidean_Domain

(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section ‹Executable Smith normal form algorithm over Euclidean domains›

theory SNF_Algorithm_Euclidean_Domain
  imports
    Diagonal_To_Smith
    Echelon_Form.Examples_Echelon_Form_Abstract

    Elementary_Divisor_Rings 
    Diagonal_To_Smith_JNF

    Mod_Type_Connect
    Show.Show_Instances
    Jordan_Normal_Form.Show_Matrix
    Show.Show_Poly    
begin

text ‹This provides an executable implementation of the verified general algorithm, provinding
executable operations over a Euclidean domain.›

lemma zero_less_one_type2: "(0::2) < 1"
proof -
  have "Mod_Type.from_nat 0 = (0::2)" by (simp add: from_nat_0)
  moreover have "Mod_Type.from_nat 1 = (1::2)" using from_nat_1 by blast
  moreover have "(Mod_Type.from_nat 0::2) < Mod_Type.from_nat 1" by (rule from_nat_mono, auto)
  ultimately show ?thesis by simp
qed

subsection ‹Previous code equations›
(*Firstly, code equations for Mod_Type_Connect.to_hmam*)

definition "to_hmam_row A i
  = (vec_lambda (λj. A $$ (Mod_Type.to_nat i, Mod_Type.to_nat j)))"

lemma bezout_matrix_row_code [code abstract]:
  "vec_nth (to_hmam_row A i) = 
      (λj. A $$ (Mod_Type.to_nat i, Mod_Type.to_nat j))"
  unfolding to_hmam_row_def by auto 

lemma [code abstract]: "vec_nth (Mod_Type_Connect.to_hmam A) = to_hmam_row A"
  unfolding Mod_Type_Connect.to_hmam_def  unfolding to_hmam_row_def[abs_def]
  by auto


subsection ‹An executable algorithm to transform $2 \times 2$ matrices into its Smith normal form
in HOL Analysis›
(*

There are several alternatives to obtain an algorithm to transform a 2x2 matrix (over 
a euclidean domain) into its Smith normal form. One of them is diagonalize + diagonal to Smith.

To take advantage of existing results in HOL Analysis (HA), we proceed as follows:

  1) We implement an algorithm to diagonalize a matrix in HA, taking advantage of the existing 
     bezout matrix
  2) Then, we transform the diagonal matrix to its Smith normal form using the diagonal_to_Smith
     algorithm in HA, already proved.
  3) We define an algorithm in JNF based on the one in HA, which is possible since the types 
     are known. Then, transfer the results to JNF.
*)

subclass (in euclidean_ring_gcd) bezout_ring_div
proof qed

(*value[code] "let (P,S,Q) = (diagonal_to_Smith_PQ ((list_of_list_to_matrix [[4,0],[0,10]])::int^2^2) euclid_ext2)
  in (matrix_to_list_of_list P,matrix_to_list_of_list S,matrix_to_list_of_list Q)"*)

context
  fixes bezout::"('a::euclidean_ring_gcd  'a  ('a×'a×'a×'a×'a))"
  assumes ib: "is_bezout_ext bezout"
begin

lemma normalize_bezout_gcd: 
  assumes b: "(p,q,u,v,d) = bezout a b"
  shows "normalize d = gcd a b"
proof -
  let ?gcd = "(λa b. case bezout a b of (x, xa,u,v, gcd')  gcd')"
  have is_gcd: "is_gcd ?gcd" by (simp add: ib is_gcd_is_bezout_ext)
  have "(?gcd a b) = d" using b by (metis case_prod_conv)
  moreover have "normalize (?gcd a b) = normalize (gcd a b)"
  proof (rule associatedI)
    show "(?gcd a b) dvd (gcd a b)" using is_gcd is_gcd_def by fastforce
    show "(gcd a b) dvd (?gcd a b)" by (metis (no_types) gcd_dvd1 gcd_dvd2 is_gcd is_gcd_def)
  qed
  ultimately show ?thesis by auto
qed

end


lemma bezout_matrix_works_transpose1:
  assumes ib: "is_bezout_ext bezout"
  and a_not_b: "a  b"
shows "(A**transpose (bezout_matrix (transpose A) a b i bezout)) $ i $ a 
    = snd (snd (snd (snd (bezout (A $ i $ a) (A $ i $ b)))))"
proof -
  have "(A**transpose (bezout_matrix (transpose A) a b i bezout)) $h i $h a 
    = transpose (A**transpose (bezout_matrix (transpose A) a b i bezout)) $h a $h i"
    by (simp add: transpose_code transpose_row_code)
  also have "... = ((bezout_matrix (transpose A) a b i bezout) ** (transpose A)) $h a $h i"
    by (simp add: matrix_transpose_mul)
  also have "... = snd (snd (snd (snd (bezout ((transpose A) $ a $ i) ((transpose A) $ b $ i)))))"
    by (rule bezout_matrix_works1[OF ib a_not_b])
  also have "... = snd (snd (snd (snd (bezout (A $ i $ a) (A $ i $ b)))))"
    by (simp add: transpose_code transpose_row_code)
  finally show ?thesis .
qed

lemma invertible_bezout_matrix_transpose:
 fixes A::"'a::{bezout_ring_div}^'cols::{finite,wellorder}^'rows"
  assumes ib: "is_bezout_ext bezout"
  and a_less_b: "a < b"
  and aj: "A $h i $h a  0"
shows "invertible (transpose (bezout_matrix (transpose A) a b i bezout))"
proof -
  have "Determinants.det (bezout_matrix (transpose A) a b i bezout) = 1"
    by (rule det_bezout_matrix[OF ib a_less_b], insert aj, auto simp add: transpose_def)
  hence "Determinants.det (transpose (bezout_matrix (transpose A) a b i bezout)) = 1" by simp
  thus ?thesis by (simp add: invertible_iff_is_unit)
qed


(*I will have to ensure that a is not zero before starting the algorithm (moving the pivot)*)
function diagonalize_2x2_aux :: "(('a::euclidean_ring_gcd^2^2) × ('a^2^2)×('a^2^2))  
                                  (('a^2^2) ×('a^2^2)×('a^2^2))"
  where "diagonalize_2x2_aux (P,A,Q)  =
(
  let 
      a = A $h 0 $h 0;
      b = A $h 0 $h 1;
      c = A $h 1 $h 0;
      d = A $h 1 $h 1 in
      if a 0  ¬ a dvd b then let bezout_mat = transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2) in
       diagonalize_2x2_aux (P, A**bezout_mat,Q**bezout_mat) else
        if  a  0  ¬ a dvd c then let bezout_mat = bezout_matrix A 0 1 0 euclid_ext2
      in diagonalize_2x2_aux (bezout_mat**P,bezout_mat**A,Q) else ― ‹We can divide an get zeros›
      let Q' = column_add (Finite_Cartesian_Product.mat 1) 1 0 (- (b div a));
          P' = row_add (Finite_Cartesian_Product.mat 1) 1 0 (- (c div a)) in
        (P'**P,P'**A**Q',Q**Q')
)" by auto

(*The algorithm terminates since the euclidean size of the A $h 0 $h 0 element gets reduced.*)
termination 
proof-
  have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2)
  have "euclidean_size ((bezout_matrix A 0 1 0 euclid_ext2 ** A) $h 0 $h 0) < euclidean_size (A $h 0 $h 0)"
    if a_not_dvd_c: "¬ A $h 0 $h 0 dvd A $h 1 $h 0" and a_not0: "A $h 0 $h 0  0" for A::"'a^2^2"
  proof-
    let ?a = "(A $h 0 $h 0)" let ?c = "(A $h 1 $h 0)"
    obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 ?a ?c" by (metis prod_cases5)
    have "(bezout_matrix A 0 1 0 euclid_ext2 ** A) $h 0 $h 0 = d"      
      by (metis bezout_matrix_works1 ib one_neq_zero pquvd prod.sel(2))
    hence "normalize ((bezout_matrix A 0 1 0 euclid_ext2 ** A) $h 0 $h 0) = normalize d" by auto
    also have "... = gcd ?a ?c" by (rule normalize_bezout_gcd[OF ib pquvd])
    finally have "euclidean_size ((bezout_matrix A 0 1 0 euclid_ext2 ** A) $h 0 $h 0) 
      = euclidean_size (gcd ?a ?c)" by (metis euclidean_size_normalize)
    also have "... < euclidean_size ?a" by (rule euclidean_size_gcd_less1[OF a_not0 a_not_dvd_c])
    finally show ?thesis .
  qed
  moreover have "euclidean_size ((A ** transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)) $h 0 $h 0)
      < euclidean_size (A $h 0 $h 0)"
    if a_not_dvd_b: "¬ A $h 0 $h 0 dvd A $h 0 $h 1" and a_not0: "A $h 0 $h 0  0" for A::"'a^2^2"
  proof-
    let ?a = "(A $h 0 $h 0)" let ?b = "(A $h 0 $h 1)"
    obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 ?a ?b" by (metis prod_cases5)
    have "(A ** transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)) $h 0 $h 0 = d"
      by (metis bezout_matrix_works_transpose1 ib pquvd prod.sel(2) zero_neq_one)
    hence "normalize ((A ** transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)) $h 0 $h 0) = normalize d" by auto
    also have "... = gcd ?a ?b" by (rule normalize_bezout_gcd[OF ib pquvd])
    finally have "euclidean_size ((A ** transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)) $h 0 $h 0)
      = euclidean_size (gcd ?a ?b)" by (metis euclidean_size_normalize)
    also have "... < euclidean_size ?a" by (rule euclidean_size_gcd_less1[OF a_not0 a_not_dvd_b])
    finally show ?thesis .
  qed
  ultimately show ?thesis
    by (relation "Wellfounded.measure (λ(P,A,Q). euclidean_size (A $h 0 $h 0))", auto)
qed


lemma diagonalize_2x2_aux_works:
  assumes  "A = P ** A_input ** Q"
    and "invertible P" and "invertible Q"
    and "(P',D,Q') = diagonalize_2x2_aux (P,A,Q)"
    and "A $h 0 $h 0  0"
  shows "D = P' ** A_input ** Q'  invertible P'  invertible Q'  isDiagonal D"
  using assms
proof (induct "(P,A,Q)" arbitrary: P A Q rule: diagonalize_2x2_aux.induct)
  case (1 P A Q)
  let ?a = "A $h 0 $h 0"
  let ?b = "A $h 0 $h 1"
  let ?c = "A $h 1 $h 0"
  let ?d = "A $h 1 $h 1"
  have a_not_0: "?a  0" using "1.prems" by blast
  have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2)
  have one_not_zero: "1  (0::2)" by auto
  show ?case 
  proof (cases "¬ ?a dvd ?b")
    case True
    let ?bezout_mat_right = "transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)"
    have "(P', D, Q') = diagonalize_2x2_aux (P, A, Q)" using "1.prems" by blast 
    also have "... = diagonalize_2x2_aux (P, A** ?bezout_mat_right, Q ** ?bezout_mat_right)"
      using True a_not_0 by (auto simp add: Let_def)
    finally have eq: "(P',D,Q') = ..." .
    show ?thesis
    proof (rule "1.hyps"(1)[OF  _ _ _ _ _ _ _ _ _ eq])
      have "invertible ?bezout_mat_right" 
        by (rule invertible_bezout_matrix_transpose[OF ib zero_less_one_type2 a_not_0])
      thus "invertible (Q ** ?bezout_mat_right)"
        using "1.prems" invertible_mult by blast
      show "A ** ?bezout_mat_right = P ** A_input ** (Q ** ?bezout_mat_right)"
        by (simp add: "1.prems" matrix_mul_assoc)    
      show "(A ** ?bezout_mat_right) $h 0 $h 0  0"
        by (metis (no_types, lifting) a_not_0 bezout_matrix_works_transpose1 bezout_matrix_not_zero  
           bezout_matrix_works1 is_bezout_ext_euclid_ext2 one_neq_zero transpose_code transpose_row_code)
    qed (insert True a_not_0  "1.prems", blast+)
  next
    case False note a_dvd_b = False
    show ?thesis
    proof (cases "¬ ?a dvd ?c")
      case True
      let ?bezout_mat = "(bezout_matrix A 0 1 0 euclid_ext2)"
      have "(P', D, Q') = diagonalize_2x2_aux (P, A, Q)" using "1.prems" by blast 
      also have "... = diagonalize_2x2_aux (?bezout_mat**P, ?bezout_mat ** A, Q)"
      using True a_dvd_b a_not_0 by (auto simp add: Let_def)
      finally have eq: "(P',D,Q') = ..." .
      show ?thesis 
      proof (rule "1.hyps"(2)[OF _ _ _ _ _ _ _ _ _ _ eq])
        have "invertible ?bezout_mat" 
        by (rule invertible_bezout_matrix[OF ib zero_less_one_type2 a_not_0])
        thus "invertible (?bezout_mat ** P)"
          using "1.prems" invertible_mult by blast
        show "?bezout_mat ** A = (?bezout_mat ** P) ** A_input ** Q"
          by (simp add: "1.prems" matrix_mul_assoc)
        show "(?bezout_mat ** A) $h 0 $h 0  0"
          by (simp add: a_not_0 bezout_matrix_not_zero is_bezout_ext_euclid_ext2)
      qed (insert True a_not_0 a_dvd_b "1.prems", blast+)
    next
      case False
      hence a_dvd_c: "?a dvd ?c" by simp
      let ?Q' = "column_add (Finite_Cartesian_Product.mat 1) 1 0 (- (?b div ?a))::'a^2^2"
      let ?P' = "(row_add (Finite_Cartesian_Product.mat 1) 1 0 (- (?c div ?a)))::'a^2^2"
      have eq: "(P', D, Q') =  (?P'**P,?P'**A**?Q',Q**?Q')" 
        using "1.prems" a_dvd_b a_dvd_c a_not_0 by (auto simp add: Let_def)
      have d: "isDiagonal (?P'**A**?Q')"
      proof -
        {
        fix a b::2 assume a_not_b: "a  b"
        have "(?P' ** A ** ?Q') $h a $h b = 0"
        proof (cases "(a,b) = (0,1)")
          case True
          hence a0: "a = 0" and b1: "b = 1" by auto
          have "(?P' ** A ** ?Q') $h a $h b = (?P' ** (A ** ?Q')) $h a $h b" 
            by (simp add: matrix_mul_assoc)
          also have "... = (A**?Q') $h a $h b" unfolding row_add_mat_1
            by (smt True a_not_b prod.sel(2) row_add_def vec_lambda_beta)
          also have "... = 0" unfolding column_add_mat_1 a0 b1
            by (smt Groups.mult_ac(2) a_dvd_b ab_group_add_class.ab_left_minus add_0_left
                add_diff_cancel_left' add_uminus_conv_diff column_add_code_nth column_add_row_def
                comm_semiring_class.distrib dvd_div_mult_self vec_lambda_beta)
          finally show ?thesis .
        next
          case False
          hence a1: "a = 1" and b0: "b = 0"
            by (metis (no_types, hide_lams) False a_not_b exhaust_2 zero_neq_one)+
          have "(?P' ** A ** ?Q') $h a $h b = (?P' ** A) $h a $h b" 
            unfolding a1 b0 column_add_mat_1
            by (simp add: column_add_code_nth column_add_row_def)
          also have "... = 0" unfolding row_add_mat_1 a1 b0
            by (simp add: a_dvd_c row_add_def)
          finally show ?thesis .
        qed}
      thus ?thesis unfolding isDiagonal_def by auto
      qed
      have inv_P': "invertible ?P'" by (rule invertible_row_add[OF one_not_zero])
      have inv_Q': "invertible ?Q'" by (rule invertible_column_add[OF one_not_zero])
      have "invertible (?P'**P)" using "1.prems"(2) inv_P' invertible_mult by blast
      moreover have "invertible (Q**?Q')" using "1.prems"(3) inv_Q' invertible_mult by blast
      moreover have "D = P' ** A_input ** Q'"
        by (metis (no_types, lifting) "1.prems"(1) Pair_inject eq matrix_mul_assoc)
      ultimately show ?thesis using eq d by auto
    qed    
  qed
qed


definition "diagonalize_2x2 A = 
  (if A $h 0 $h 0 = 0 then 
        if A $h 0 $h 1  0 then 
            let A' = interchange_columns A 0 1;
                Q' = interchange_columns (Finite_Cartesian_Product.mat 1) 0 1 in
            diagonalize_2x2_aux (Finite_Cartesian_Product.mat 1, A', Q')
        else 
            if A $h 1 $h 0  0 then
                  let A' = interchange_rows A 0 1;
                      P' = interchange_rows (Finite_Cartesian_Product.mat 1) 0 1 in
                   diagonalize_2x2_aux (P', A', Finite_Cartesian_Product.mat 1)
            else (Finite_Cartesian_Product.mat 1,A,Finite_Cartesian_Product.mat 1)
   else diagonalize_2x2_aux (Finite_Cartesian_Product.mat 1,A,Finite_Cartesian_Product.mat 1)
)"


lemma diagonalize_2x2_works:
  assumes PDQ: "(P,D,Q) = diagonalize_2x2 A"
  shows "D = P ** A ** Q  invertible P  invertible Q  isDiagonal D"
proof -
  let ?a = "A $h 0 $h 0"
  let ?b = "A $h 0 $h 1"
  let ?c = "A $h 1 $h 0"
  let ?d = "A $h 1 $h 1"
  show ?thesis
  proof (cases "?a = 0")
    case False
    hence eq: "(P,D,Q) = diagonalize_2x2_aux (Finite_Cartesian_Product.mat 1,A,Finite_Cartesian_Product.mat 1)"
      using PDQ unfolding diagonalize_2x2_def by auto 
    show ?thesis 
      by (rule diagonalize_2x2_aux_works[OF _ _ _ eq False], auto simp add: invertible_mat_1)
  next
    case True note a0 = True
    show ?thesis
    proof (cases "?b  0")
      case True
      let ?A' = "interchange_columns A 0 1"
      let ?Q' = "(interchange_columns (Finite_Cartesian_Product.mat 1) 0 1)::'a^2^2"
      have eq: "(P,D,Q) = diagonalize_2x2_aux (Finite_Cartesian_Product.mat 1, ?A', ?Q')"
        using PDQ a0 True unfolding diagonalize_2x2_def by (auto simp add: Let_def)
      show ?thesis 
      proof (rule diagonalize_2x2_aux_works[OF _ _ _ eq _])
        show "?A' $h 0 $h 0  0"
          by (simp add: True interchange_columns_code interchange_columns_code_nth)
        show "invertible ?Q'" by (simp add: invertible_interchange_columns)
        show "?A' = Finite_Cartesian_Product.mat 1 ** A ** ?Q'"
          by (simp add: interchange_columns_mat_1)
      qed (auto simp add: invertible_mat_1)
    next
      case False note b0 = False
      show ?thesis
      proof (cases "?c  0")
        case True
        let ?A' = "interchange_rows A 0 1"
        let ?P' = "(interchange_rows (Finite_Cartesian_Product.mat 1) 0 1)::'a^2^2"
        have eq: "(P,D,Q) = diagonalize_2x2_aux (?P', ?A',Finite_Cartesian_Product.mat 1)"
          using PDQ a0 b0 True unfolding diagonalize_2x2_def by (auto simp add: Let_def)
        show ?thesis 
        proof (rule diagonalize_2x2_aux_works[OF _ _ _ eq _])
          show "?A' $h 0 $h 0  0"
            by (simp add: True interchange_columns_code interchange_columns_code_nth)
          show "invertible ?P'" by (simp add: invertible_interchange_rows)
          show "?A' = ?P' ** A ** Finite_Cartesian_Product.mat 1"
            by (simp add: interchange_rows_mat_1)
        qed (auto simp add: invertible_mat_1)
      next
        case False
        have eq: "(P,D,Q) = (Finite_Cartesian_Product.mat 1, A,Finite_Cartesian_Product.mat 1)"
          using PDQ a0 b0 True False unfolding diagonalize_2x2_def by (auto simp add: Let_def)
        have "isDiagonal A" unfolding isDiagonal_def using a0 b0 True False
          by (metis (full_types) exhaust_2 one_neq_zero) 
        thus ?thesis using invertible_mat_1 eq by auto
      qed  
    qed
  qed
qed
  

definition "diagonalize_2x2_JNF (A::'a::euclidean_ring_gcd mat) 
  = (let (P,D,Q) = diagonalize_2x2 (Mod_Type_Connect.to_hmam A::'a^2^2) in 
  (Mod_Type_Connect.from_hmam P,Mod_Type_Connect.from_hmam D,Mod_Type_Connect.from_hmam Q))"


(*Obtained via transfer rules*)
lemma diagonalize_2x2_JNF_works:
  assumes A: "A  carrier_mat 2 2"
  and PDQ: "(P,D,Q) = diagonalize_2x2_JNF A"
  shows "D = P * A * Q  invertible_mat P  invertible_mat Q  isDiagonal_mat D  Pcarrier_mat 2 2
   Q  carrier_mat 2 2  D  carrier_mat 2 2"
proof -
  let ?A = "(Mod_Type_Connect.to_hmam A::'a^2^2)"
  have A[transfer_rule]: "Mod_Type_Connect.HMA_M A ?A" 
    using A unfolding Mod_Type_Connect.HMA_M_def by auto
  obtain P_HMA D_HMA Q_HMA where PDQ_HMA: "(P_HMA,D_HMA,Q_HMA) = diagonalize_2x2 ?A" 
    by (metis prod_cases3)
(*  have "HMA_M3 (diagonalize_2x2_JNF A) (diagonalize_2x2 ?A)"
    using HMA_diagonalize_2x2 A rel_funE by fastforce*)  
  have P: "P = Mod_Type_Connect.from_hmam P_HMA" and Q: "Q = Mod_Type_Connect.from_hmam Q_HMA" 
    and D: "D = Mod_Type_Connect.from_hmam D_HMA" 
    using PDQ_HMA PDQ unfolding diagonalize_2x2_JNF_def 
    by (metis prod.simps(1) split_conv)+ 
  have [transfer_rule]: "Mod_Type_Connect.HMA_M P P_HMA" 
    unfolding Mod_Type_Connect.HMA_M_def using P by auto
  have [transfer_rule]: "Mod_Type_Connect.HMA_M Q Q_HMA" 
    unfolding Mod_Type_Connect.HMA_M_def using Q by auto
  have [transfer_rule]: "Mod_Type_Connect.HMA_M D D_HMA" 
    unfolding Mod_Type_Connect.HMA_M_def using D by auto
  have r: "D_HMA = P_HMA ** ?A ** Q_HMA  invertible P_HMA  invertible Q_HMA  isDiagonal D_HMA"
    by (rule diagonalize_2x2_works[OF PDQ_HMA])
  have "D = P * A * Q  invertible_mat P  invertible_mat Q  isDiagonal_mat D" 
    using r by (transfer, rule)
  thus ?thesis using P Q D by auto 
qed



(*The full algorithm in HOL Analysis*)
definition "Smith_2x2_eucl A = (
  let (P,D,Q) = diagonalize_2x2 A;
      (P',S,Q') = diagonal_to_Smith_PQ D euclid_ext2
  in (P' ** P, S, Q ** Q'))"

lemma Smith_2x2_eucl_works:
  assumes PBQ: "(P,S,Q) = Smith_2x2_eucl A"
  shows "S = P ** A ** Q  invertible P  invertible Q  Smith_normal_form S"   
proof -
  have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2)
  obtain P1 D Q1 where P1DQ1: "(P1,D,Q1) = diagonalize_2x2 A" by (metis prod_cases3)
  obtain P2 S' Q2 where P2SQ2:"(P2,S',Q2) = diagonal_to_Smith_PQ D euclid_ext2" 
    by (metis prod_cases3)
  have P: "P = P2 ** P1" and S: "S = S'" and Q: "Q = Q1 ** Q2"
    by (metis (mono_tags, lifting) PBQ Pair_inject Smith_2x2_eucl_def P1DQ1 P2SQ2 old.prod.case)+
  have 1: "D = P1 ** A ** Q1  invertible P1  invertible Q1  isDiagonal D" 
    by (rule diagonalize_2x2_works[OF P1DQ1])
  have 2: "S' = P2 ** D ** Q2  invertible P2  invertible Q2  Smith_normal_form S'"
    by (rule diagonal_to_Smith_PQ'[OF _ ib P2SQ2], insert 1, auto)
  show ?thesis using 1 2 P S Q by (simp add: 2 invertible_mult matrix_mul_assoc)
qed


subsection ‹An executable algorithm to transform $2 \times 2$ matrices into its Smith normal form
in JNF›
(*The full algorithm in JNF*)
definition "Smith_2x2_JNF_eucl A = (
  let (P,D,Q) = diagonalize_2x2_JNF A;
      (P',S,Q') = diagonal_to_Smith_PQ_JNF D euclid_ext2
  in (P' * P, S, Q * Q'))"

lemma Smith_2x2_JNF_eucl_works:
  assumes A: "A  carrier_mat 2 2"
    and PBQ: "(P,S,Q) = Smith_2x2_JNF_eucl A"
  shows "is_SNF A (P,S,Q)"
proof -
  have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2)
  obtain P1 D Q1 where P1DQ1: "(P1,D,Q1) = diagonalize_2x2_JNF A" by (metis prod_cases3)
  obtain P2 S' Q2 where P2SQ2: "(P2,S',Q2) = diagonal_to_Smith_PQ_JNF D euclid_ext2" 
    by (metis prod_cases3)
  have P: "P = P2 * P1" and S: "S = S'" and Q: "Q = Q1 * Q2"
    by (metis (mono_tags, lifting) PBQ Pair_inject Smith_2x2_JNF_eucl_def P1DQ1 P2SQ2 old.prod.case)+             
  have 1: "D = P1 * A * Q1  invertible_mat P1  invertible_mat Q1  isDiagonal_mat D
     P1  carrier_mat 2 2  Q1  carrier_mat 2 2  D  carrier_mat 2 2"
    by (rule diagonalize_2x2_JNF_works[OF A P1DQ1])
  have 2: "S' = P2 * D * Q2  invertible_mat P2  invertible_mat Q2  Smith_normal_form_mat S' 
         P2  carrier_mat 2 2  S'  carrier_mat 2 2  Q2  carrier_mat 2 2"
    by (rule diagonal_to_Smith_PQ_JNF[OF _ ib _ P2SQ2], insert 1, auto)
  show ?thesis
  proof (rule is_SNF_intro)
    have dim_Q: "Q  carrier_mat 2 2" using Q 1 2 by auto
    have P1AQ1: "(P1*A*Q1)  carrier_mat 2 2" using 1 2 A by auto
    have rw1: "(P1 * A * Q1) * Q2 = (P1 * A * (Q1 * Q2))" 
      by (meson "1" "2" A assoc_mult_mat mult_carrier_mat)
    have rw2: "(P1 * A * Q) = P1 * (A * Q)" by (rule assoc_mult_mat[OF _ A dim_Q], insert 1, auto)
    show "invertible_mat Q" using 1 2 Q invertible_mult_JNF by blast
    show "invertible_mat P" using 1 2 P invertible_mult_JNF by blast
    have "P2 * D * Q2 = P2 * (P1 * A * Q1) * Q2" using 1 2 by auto   
    also have "... = P2 * ((P1 * A * Q1) * Q2)" using 1 2 by auto
    also have "... = P2 * (P1 * A * (Q1 * Q2))" unfolding rw1 by simp
    also have "... = P2 * (P1 * A * Q)" using Q by auto
    also have "... = P2 * (P1 * (A * Q))" unfolding rw2 by simp
    also have "... = P2 * P1 * (A * Q)" by (rule assoc_mult_mat[symmetric], insert 1 2 A Q, auto)
    also have "... = P*(A*Q)" unfolding P by simp
    also have "... = P*A*Q" by (rule assoc_mult_mat[symmetric], insert 1 2 A Q P, auto)
    finally show "S = P * A * Q" using 1 2 S by auto
  qed (insert 1 2 P Q A S, auto)
qed

subsection ‹An executable algorithm to transform $1 \times 2$ matrices into its Smith normal form›

(*Let's move to prove the case 1x2*)

(*This is not executable since type 1 is not mod_type*)
definition "Smith_1x2_eucl (A::'a::euclidean_ring_gcd^2^1) = (
  if A $h 0 $h 0 = 0  A $h 0 $h 1  0 then 
    let Q = interchange_columns (Finite_Cartesian_Product.mat 1) 0 1;
        A' = interchange_columns A 0 1 in (A',Q)
  else
    if A $h 0 $h 0  0  A $h 0 $h 1  0 then
      let bezout_matrix_right = transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)
      in (A ** bezout_matrix_right, bezout_matrix_right)
    else (A, Finite_Cartesian_Product.mat 1)
  )"


lemma Smith_1x2_eucl_works:
  assumes SQ: "(S,Q) = Smith_1x2_eucl A"
  shows "S = A ** Q  invertible Q  S $h 0 $h 1 = 0"
proof (cases "A $h 0 $h 0 = 0  A $h 0 $h 1  0")
  case True
  have Q: "Q = interchange_columns (Finite_Cartesian_Product.mat 1) 0 1"
    and S: "S = interchange_columns A 0 1" 
    using SQ True unfolding Smith_1x2_eucl_def by (auto simp add: Let_def)
  have "S $h 0 $h 1 = 0" by (simp add: S True interchange_columns_code interchange_columns_code_nth)
  moreover have "invertible Q" using Q invertible_interchange_columns by blast
  moreover have "S = A ** Q" by (simp add: Q S interchange_columns_mat_1)
  ultimately show ?thesis by simp
next
  case False note A00_A01 = False
  show ?thesis
  proof (cases "A $h 0 $h 0  0  A $h 0 $h 1  0")
    case True
    have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2)
    let ?bezout_matrix_right = "transpose (bezout_matrix (transpose A) 0 1 0 euclid_ext2)"
    have Q: "Q = ?bezout_matrix_right" and S: "S = A**?bezout_matrix_right" 
      using SQ True A00_A01 unfolding Smith_1x2_eucl_def by (auto simp add: Let_def)
    have "invertible Q" unfolding Q
      by (rule invertible_bezout_matrix_transpose[OF ib zero_less_one_type2], insert True, auto)
    moreover have "S $h 0 $h 1 = 0"
      by (smt Finite_Cartesian_Product.transpose_transpose S True bezout_matrix_works2 ib 
          matrix_transpose_mul rel_simps(92) transpose_code transpose_row_code)
    moreover have "S = A**Q" unfolding S Q by simp
    ultimately show ?thesis by simp
  next
    case False
    have Q: "Q = (Finite_Cartesian_Product.mat 1)" and S: "S = A" 
      using SQ False A00_A01 unfolding Smith_1x2_eucl_def by (auto simp add: Let_def)
    show ?thesis using False A00_A01 S Q invertible_mat_1 by auto
  qed
qed


(*Bezout_matrix in JNF*)
definition bezout_matrix_JNF :: "'a::comm_ring_1 mat  nat  nat  nat 
     ('a  'a  ('a × 'a × 'a × 'a × 'a))  'a mat"
  where 
  "bezout_matrix_JNF A a b j bezout = Matrix.mat (dim_row A) (dim_row A) (λ(x,y). 
      (let 
        (p, q, u, v, d) = bezout (A $$ (a, j)) (A $$ (b, j)) 
       in
         if x = a  y = a then p else
         if x = a  y = b then q else
         if x = b  y = a then u else
         if x = b  y = b then v else
         if x = y then 1 else 0))"


definition "Smith_1x2_eucl_JNF (A::'a::euclidean_ring_gcd mat) = (
  if A $$ (0, 0) = 0  A $$ (0, 1)  0 then 
    let Q = swaprows_mat 2 0 1;
        A' = swapcols 0 1 A 
     in (A',Q)
  else
    if A $$ (0, 0)  0  A $$ (0, 1)  0 then
      let bezout_matrix_right = transpose_mat (bezout_matrix_JNF (transpose_mat A) 0 1 0 euclid_ext2)
      in (A * bezout_matrix_right, bezout_matrix_right)
    else (A, 1m 2)
  )"


lemma Smith_1x2_eucl_JNF_works:
  assumes A: "A  carrier_mat 1 2"
  and SQ: "(S,Q) = Smith_1x2_eucl_JNF A"
shows "is_SNF A (1m 1, (Smith_1x2_eucl_JNF A))"
proof -
  have i: "0<dim_row A" and j: "1<dim_col A" using A by auto
  have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2)
  show ?thesis
  proof (cases "A $$ (0, 0) = 0  A $$ (0, 1)  0")
    case True
    have Q: "Q = swaprows_mat 2 0 1"
      and S: "S = swapcols 0 1 A"
      using SQ True unfolding Smith_1x2_eucl_JNF_def by (auto simp add: Let_def)
    have S01: "S $$ (0,1) = 0" unfolding S using index_mat_swapcols j i True by simp
    have dim_S: "S  carrier_mat 1 2" using S A by auto
    moreover have dim_Q: "Q  carrier_mat 2 2" using S Q by auto
    moreover have "invertible_mat Q" (*TODO: better a lemma for invertible swaprows_mat, etc*)
    proof -
      have "Determinant.det (swaprows_mat 2 0 1) = -1" by (rule det_swaprows_mat, auto)
      also have "... dvd 1" by simp
      finally show ?thesis using Q dim_Q invertible_iff_is_unit_JNF by blast
    qed
    moreover have "S = A * Q" unfolding S Q using A by (simp add: swapcols_mat)
    moreover have "Smith_normal_form_mat S" unfolding Smith_normal_form_mat_def isDiagonal_mat_def
      using S01 dim_S less_2_cases by fastforce
    ultimately show ?thesis using SQ S Q A unfolding is_SNF_def by auto
  next
    case False note A00_A01 = False
    show ?thesis
    proof (cases "A $$ (0,0)  0  A $$ (0,1)  0")
      case True
      have ib: "is_bezout_ext euclid_ext2" by (simp add: is_bezout_ext_euclid_ext2)
      let ?BM = "(bezout_matrix_JNF AT 0 1 0 euclid_ext2)T"
      have Q: "Q = ?BM" and S: "S = A*?BM" 
        using SQ True A00_A01 unfolding Smith_1x2_eucl_JNF_def by (auto simp add: Let_def)
      let ?a = "A $$ (0, 0)" let ?b = "A $$ (0, Suc 0)"
      obtain p q u v d where pquvd: "(p,q,u,v,d) = euclid_ext2 ?a ?b" by (metis prod_cases5)
      have d: "p*?a + q*?b = d" and u: "u = - ?b div d" and v: "v = ?a div d" 
        using pquvd unfolding euclid_ext2_def using bezout_coefficients_fst_snd by blast+   
      have da: "d dvd ?a" and db: "d dvd ?b" and gcd_ab: "d = gcd ?a ?b" 
        by (metis euclid_ext2_def gcd_dvd1 gcd_dvd2 pquvd prod.sel(2))+
      have dim_S: "S  carrier_mat 1 2" using S A by (simp add: bezout_matrix_JNF_def)
      moreover have dim_Q: "Q  carrier_mat 2 2" using A Q by (simp add: bezout_matrix_JNF_def)
      have "invertible_mat Q" 
      proof -
        have "Determinant.det ?BM = ?BM $$ (0, 0) * ?BM $$ (1, 1) - ?BM $$ (0, 1) * ?BM $$ (1, 0)"
          by (rule det_2, insert A, auto simp add: bezout_matrix_JNF_def)
        also have "... = p * v - u*q" 
          by (insert i j pquvd, auto simp add: bezout_matrix_JNF_def, metis split_conv)
        also have "... = (p * ?a) div d - (q * (-?b)) div d" unfolding v u
          by (simp add: da db div_mult_swap mult.commute)
        also have "... = (p * ?a + q * ?b) div d"
          by (metis (no_types, lifting) da db diff_minus_eq_add div_diff dvd_minus_iff dvd_trans 
              dvd_triv_right more_arith_simps(8))
        also have "... = 1 " unfolding d using True da by fastforce
        finally show ?thesis unfolding Q 
          by (metis (full_types) Determinant.det_def Q carrier_matI invertible_iff_is_unit_JNF 
              not_is_unit_0 one_dvd)
      qed
      moreover have S_AQ: "S = A*Q" unfolding S Q by simp
      moreover have S01: "S $$ (0,1) = 0"
      proof -
        have Q01: "Q $$ (0, 1) = u"
        proof -
          have "?BM $$ (0,1) = (bezout_matrix_JNF AT 0 1 0 euclid_ext2) $$ (1, 0)"
            using Q dim_Q by auto
          also have "... =  (λ(x::nat, y::nat).
          let (p, q, u, v, d) = euclid_ext2 (AT $$ (0, 0)) (AT $$ (1, 0)) in if x = 0  y = 0 then p
            else if x = 0  y = 1 then q else if x = 1  y = 0 then u else if x = 1  y = 1 then v
            else if x = y then 1 else 0) (1, 0)"
            unfolding bezout_matrix_JNF_def by (rule index_mat(1), insert A, auto)
          also have "... = u" using pquvd unfolding split_beta Let_def
            by (auto, metis A One_nat_def carrier_matD(2) fst_conv i index_transpose_mat(1) 
                j rel_simps(51) snd_conv)   
          finally show ?thesis unfolding Q by auto
        qed
        have Q11: "Q $$ (1, 1) = v"
        proof -
          have "?BM $$ (1,1) = (bezout_matrix_JNF AT 0 1 0 euclid_ext2) $$ (1, 1)"
            using Q dim_Q by auto
          also have "... =  (λ(x::nat, y::nat).
          let (p, q, u, v, d) = euclid_ext2 (AT $$ (0, 0)) (AT $$ (1, 0)) in if x = 0  y = 0 then p
            else if x = 0  y = 1 then q else if x = 1  y = 0 then u else if x = 1  y = 1 then v
            else if x = y then 1 else 0) (1, 1)"
            unfolding bezout_matrix_JNF_def by (rule index_mat(1), insert A, auto)
          also have "... = v" using pquvd unfolding split_beta Let_def
            by (auto, metis A One_nat_def carrier_matD(2) fst_conv i index_transpose_mat(1) 
                j rel_simps(51) snd_conv)   
          finally show ?thesis unfolding Q by auto
        qed      
        have "S $$ (0,1) = Matrix.row A 0  col Q 1" using index_mult_mat Q S dim_S i by auto        
        also have "... = (i = 0..<2. Matrix.row A 0 $v i * Q $$ (i, 1))"
          unfolding scalar_prod_def using dim_S dim_Q by auto
        also have "... = (i  {0,1}. Matrix.row A 0 $v i * Q $$ (i, 1))" by (rule sum.cong, auto)
        also have "... = Matrix.row A 0 $v 0 * Q $$ (0, 1) + Matrix.row A 0 $v 1 * Q $$ (1, 1)" 
          using sum_two_elements by auto
        also have "... =  ?a*u + ?b * v" unfolding Q01 Q11 using i index_row(1) j A by auto          
        also have "... = 0" unfolding u v
          by (smt Groups.mult_ac(2) Groups.mult_ac(3) add.right_inverse add_uminus_conv_diff da db 
              diff_minus_eq_add dvd_div_mult_self dvd_neg_div minus_mult_left)
        finally show ?thesis .
      qed
      moreover have "Smith_normal_form_mat S" 
        using less_2_cases S01 dim_S unfolding Smith_normal_form_mat_def isDiagonal_mat_def
        by fastforce
      ultimately show ?thesis using S Q A SQ unfolding is_SNF_def bezout_matrix_JNF_def by force
    next
      case False
      have Q: "Q = 1m 2" and S: "S = A" 
        using SQ False A00_A01 unfolding Smith_1x2_eucl_JNF_def by (auto simp add: Let_def)
      have "is_SNF A (1m 1, A, 1m 2)"
        by (rule is_SNF_intro, insert A False A00_A01 S Q A less_2_cases, 
          unfold Smith_normal_form_mat_def isDiagonal_mat_def, fastforce+)
      thus ?thesis using SQ S Q by auto
    qed
  qed
qed

subsection ‹The final executable algorithm to transform any matrix into its Smith normal form›

global_interpretation Smith_ED: Smith_Impl Smith_1x2_eucl_JNF Smith_2x2_JNF_eucl "(div)"
  defines Smith_ED_1xn_aux = Smith_ED.Smith_1xn_aux
    and Smith_ED_nx1 = Smith_ED.Smith_nx1
  and Smith_ED_1xn = Smith_ED.Smith_1xn
  and Smith_ED_2xn = Smith_ED.Smith_2xn
  and Smith_ED_nx2 = Smith_ED.Smith_nx2
  and Smith_ED_mxn = Smith_ED.Smith_mxn
proof 
  show "(A::'a mat)carrier_mat 1 2. is_SNF A (1m 1, Smith_1x2_eucl_JNF A)"
    using Smith_1x2_eucl_JNF_works prod.collapse by blast
  show "Acarrier_mat 2 2. is_SNF A (Smith_2x2_JNF_eucl A)"
    by (simp add: Smith_2x2_JNF_eucl_def Smith_2x2_JNF_eucl_works split_beta)
  show "is_div_op ((div)::'a'a'a::euclidean_ring_gcd)"
    by (unfold is_div_op_def, simp)
qed


(*
value[code] "let (P,S,Q) = diagonalize_2x2 ((list_of_list_to_matrix [[32,128],[24,20]])::int^2^2)
  in (matrix_to_list_of_list P,matrix_to_list_of_list S,matrix_to_list_of_list Q)"
value [code]  "show (diagonalize_2x2_JNF (mat_of_rows_list 2 [[1,2::int],[3,4]]))"
*)


(*
value [code]  "show (Smith_ED_mxn (mat_of_rows_list 2 [[1,2::int],[3,4]]))"

value [code]  "show (Smith_ED_mxn (mat_of_rows_list 2 
  [
    [[:2,4,1:]::rat poly, [:3,2,0,2:]],
    [[:0,2:]  , [:3,2:]]
  ]
))"
*)


end

Theory Smith_Certified

(*
    Author:      Jose Divasón
    Email:       jose.divason@unirioja.es
*)

section ‹A certified checker based on an external algorithm to compute Smith normal form›

theory Smith_Certified
  imports
    SNF_Algorithm_Euclidean_Domain
begin

text‹This (unspecified) function takes as input the matrix $A$ and returns five matrices
$(P,S,Q,P',Q')$, which must satisfy $S = PAQ$, $S$ is in Smith normal form, $P'$ and $Q'$
are the inverse matrices of $P$ and $Q$ respectively›

text‹The matrices are given in terms of lists for the sake of simplicity when connecting the
function to external solvers, like Mathematica or Sage.›

consts external_SNF ::
  "int list list  int list list × int list list × int list list × int list list × int list list"


text ‹We implement the checker by means of the following definition. The checker is implemented
in the JNF representation of matrices to make use of the Strassen matrix multiplication algorithm.
In case that the certification fails, then the verified Smith normal form algorithm is executed.
Thus, we will always get a verified result.›

definition "checker_SNF A = (
    let A' = mat_to_list A; m = dim_row A; n = dim_col A in
      case external_SNF A' of (P_ext,S_ext,Q_ext,P'_ext,Q'_ext)  let
          P = mat_of_rows_list m P_ext;
          S = mat_of_rows_list m S_ext;
          Q = mat_of_rows_list m Q_ext;
          P' = mat_of_rows_list m P'_ext;
          Q' = mat_of_rows_list m Q'_ext in
            (if dim_row P = m  dim_col P = m
               dim_row S = m  dim_col S = n
               dim_row Q = n  dim_col Q = n
               dim_row P' = m  dim_col P' = m
               dim_row Q' = n  dim_col Q' = n
               P * P' = 1m m  Q * Q' = 1m n
               Smith_normal_form_mat S  (S = P*A*Q) then
      (P,S,Q) else Code.abort (STR ''Certification failed'') (λ _. Smith_ED_mxn A))
)"

theorem checker_SNF_soudness:
  assumes A: "A  carrier_mat m n"
    and c: "checker_SNF A = (P,S,Q)"
  shows "is_SNF A (P,S,Q)"
proof -
  let ?ext = "external_SNF (mat_to_list A)"
  obtain P_ext S_ext Q_ext P'_ext Q'_ext where ext: "?ext = (P_ext,S_ext,Q_ext,P'_ext,Q'_ext)"
    by (cases "?ext", auto)
  let ?case_external = "let
          P = mat_of_rows_list m P_ext;
          S = mat_of_rows_list m S_ext;
          Q = mat_of_rows_list n Q_ext;
          P' = mat_of_rows_list m P'_ext;
          Q' = mat_of_rows_list n Q'_ext in
            (dim_row P = m  dim_col P = m
               dim_row S = m  dim_col S = n
               dim_row Q = n  dim_col Q = n
               dim_row P' = m  dim_col P' = m
               dim_row Q' = n  dim_col Q' = n
               P * P' = 1m m  Q * Q' = 1m n
               Smith_normal_form_mat S  (S = P*A*Q))"
  show ?thesis
  proof (cases ?case_external)
    case True
    define P' where "P' = mat_of_rows_list m P'_ext"
    define Q' where "Q' = mat_of_rows_list m Q'_ext"
    have S_PAQ: "S = P * A * Q "
      and SNF_S: "Smith_normal_form_mat S" and PP'_1: "P * P' = 1m m" and QQ'_1: "Q * Q' = 1m n"
      and sm_P: "square_mat P" and sm_Q: "square_mat Q"
      using ext True c A
      unfolding checker_SNF_def Let_def mat_of_rows_list_def P'_def Q'_def
      by (auto split: if_splits)
    have inv_P: "invertible_mat P"
    proof (unfold invertible_mat_def, rule conjI, rule sm_P,
        unfold inverts_mat_def, rule exI[of _ P'], rule conjI)
      show *: "P * P' = 1m (dim_row P)"
        by (metis PP'_1 True index_mult_mat(2))
      show "P' * P = 1m (dim_row P')"
      proof (rule mat_mult_left_right_inverse)
        show "P  carrier_mat (dim_row P') (dim_row P')"
          by (metis * P'_def PP'_1 True carrier_mat_triv index_one_mat(2) sm_P square_mat.elims(2))
        show "P'  carrier_mat (dim_row P') (dim_row P')"
          by (metis P'_def True carrier_mat_triv)
        show "P * P' = 1m (dim_row P')"
          by (metis P'_def PP'_1 True)
      qed
    qed
    have inv_Q: "invertible_mat Q"
    proof (unfold invertible_mat_def, rule conjI, rule sm_Q,
        unfold inverts_mat_def, rule exI[of _ Q'], rule conjI)
      show *: "Q * Q' = 1m (dim_row Q)"
        by (metis QQ'_1 True index_mult_mat(2))
      show "Q' * Q = 1m (dim_row Q')"
      proof (rule mat_mult_left_right_inverse)
        show 1: "Q  carrier_mat (dim_row Q') (dim_row Q')"
          by (metis Q'_def QQ'_1 True carrier_mat_triv dim_row_mat(1) index_mult_mat(2)
              mat_of_rows_list_def sm_Q square_mat.simps)
        thus "Q'  carrier_mat (dim_row Q') (dim_row Q')"
          by (metis * carrier_matD(1) carrier_mat_triv index_mult_mat(3) index_one_mat(3))
        show "Q * Q' = 1m (dim_row Q')" using * 1 by auto
      qed
    qed
    have "P  carrier_mat m m"
      by (metis PP'_1 True carrier_matI index_mult_mat(2) sm_P square_mat.simps)
    moreover have  "Q  carrier_mat n n"
      by (metis QQ'_1 True carrier_matI index_mult_mat(2) sm_Q square_mat.simps)
    ultimately show ?thesis unfolding is_SNF_def using inv_P inv_Q SNF_S S_PAQ A by auto
  next
    case False
    hence "checker_SNF A = Smith_ED_mxn A"
      using ext False c A
      unfolding checker_SNF_def Let_def Code.abort_def
      by (smt carrier_matD case_prod_conv dim_col_mat(1) mat_of_rows_list_def)
    then show ?thesis using Smith_ED.is_SNF_Smith_mxn[OF A] c unfolding is_SNF_def
      by auto
  qed
qed

end